home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / RXGIF.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  81.5 KB  |  2,772 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11.  
  12. unit RxGIF;
  13.  
  14. interface
  15.  
  16. {$I RX.INC}
  17.  
  18. uses Windows, RTLConsts, SysUtils, Classes, Graphics, RxGraph;
  19.  
  20. const
  21.   RT_GIF = 'GIF'; { GIF Resource Type }
  22.  
  23. type
  24.  
  25. {$IFNDEF RX_D3}
  26.  
  27.   TProgressStage = (psStarting, psRunning, psEnding);
  28.   TProgressEvent = procedure (Sender: TObject; Stage: TProgressStage;
  29.     PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
  30.     const Msg: string) of object;
  31.  
  32. { TSharedImage }
  33.  
  34.   TSharedImage = class
  35.   private
  36.     FRefCount: Integer;
  37.   protected
  38.     procedure Reference;
  39.     procedure Release;
  40.     procedure FreeHandle; virtual; abstract;
  41.     property RefCount: Integer read FRefCount;
  42.   end;
  43.  
  44. {$ENDIF RX_D3}
  45.  
  46.   TGIFVersion = (gvUnknown, gv87a, gv89a);
  47.   TGIFBits = 1..8;
  48.   TDisposalMethod = (dmUndefined, dmLeave, dmRestoreBackground,
  49.     dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
  50.  
  51.   TGIFColorItem = packed record
  52.     Red, Green, Blue: Byte;
  53.   end;
  54.  
  55.   TGIFColorTable = packed record
  56.     Count: Integer;
  57.     Colors: packed array[Byte] of TGIFColorItem;
  58.   end;
  59.  
  60.   TGIFFrame = class;
  61.   TGIFData = class;
  62.   TGIFItem = class;
  63.  
  64. { TGIFImage }
  65.  
  66.   TGIFImage = class(TGraphic)
  67.   private
  68.     FImage: TGIFData;
  69.     FVersion: TGIFVersion;
  70.     FItems: TList;
  71.     FFrameIndex: Integer;
  72.     FScreenWidth: Word;
  73.     FScreenHeight: Word;
  74.     FBackgroundColor: TColor;
  75.     FLooping: Boolean;
  76.     FCorrupted: Boolean;
  77.     FRepeatCount: Word;
  78. {$IFNDEF RX_D3}
  79.     FOnProgress: TProgressEvent;
  80. {$ENDIF}
  81.     function GetBitmap: TBitmap;
  82.     function GetCount: Integer;
  83.     function GetComment: TStrings;
  84.     function GetScreenWidth: Integer;
  85.     function GetScreenHeight: Integer;
  86.     function GetGlobalColorCount: Integer;
  87.     procedure UpdateScreenSize;
  88.     procedure SetComment(Value: TStrings);
  89.     function GetFrame(Index: Integer): TGIFFrame;
  90.     procedure SetFrameIndex(Value: Integer);
  91.     procedure SetBackgroundColor(Value: TColor);
  92.     procedure SetLooping(Value: Boolean);
  93.     procedure SetRepeatCount(Value: Word);
  94.     procedure ReadSignature(Stream: TStream);
  95.     procedure DoProgress(Stage: TProgressStage; PercentDone: Byte;
  96.       const Msg: string);
  97.     function GetCorrupted: Boolean;
  98.     function GetTransparentColor: TColor;
  99.     function GetBackgroundColor: TColor;
  100.     function GetPixelFormat: TPixelFormat;
  101.     procedure EncodeFrames(ReverseDecode: Boolean);
  102.     procedure ReadStream(Size: Longint; Stream: TStream; ForceDecode: Boolean);
  103.     procedure WriteStream(Stream: TStream; WriteSize: Boolean);
  104.   protected
  105.     procedure AssignTo(Dest: TPersistent); override;
  106.     procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
  107. {$IFDEF WIN32}
  108.     function Equals(Graphic: TGraphic): Boolean; override;
  109. {$ENDIF}
  110.     function GetEmpty: Boolean; override;
  111.     function GetHeight: Integer; override;
  112.     function GetWidth: Integer; override;
  113.     function GetPalette: HPALETTE; {$IFDEF RX_D3} override; {$ENDIF}
  114.     function GetTransparent: Boolean; {$IFDEF RX_D3} override; {$ENDIF}
  115.     procedure ClearItems;
  116.     procedure NewImage;
  117.     procedure UniqueImage;
  118. {$IFNDEF RX_D3}
  119.     procedure Progress(Sender: TObject; Stage: TProgressStage;
  120.       PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
  121.       const Msg: string); dynamic;
  122. {$ENDIF}
  123.     procedure ReadData(Stream: TStream); override;
  124.     procedure SetHeight(Value: Integer); override;
  125.     procedure SetWidth(Value: Integer); override;
  126.     procedure WriteData(Stream: TStream); override;
  127.     property Bitmap: TBitmap read GetBitmap;   { volatile }
  128.   public
  129.     constructor Create; override;
  130.     destructor Destroy; override;
  131.     procedure Clear;
  132.     procedure DecodeAllFrames;
  133.     procedure EncodeAllFrames;
  134.     procedure Assign(Source: TPersistent); override;
  135.     procedure LoadFromStream(Stream: TStream); override;
  136.     procedure SaveToStream(Stream: TStream); override;
  137.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  138.       APalette: HPALETTE); override;
  139.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  140.       var APalette: HPALETTE); override;
  141.     procedure LoadFromResourceName(Instance: THandle; const ResName: string;
  142.       ResType: PChar);
  143.     procedure LoadFromResourceID(Instance: THandle; ResID: Integer;
  144.       ResType: PChar);
  145.     function AddFrame(Value: TGraphic): Integer; virtual;
  146.     procedure DeleteFrame(Index: Integer);
  147.     procedure MoveFrame(CurIndex, NewIndex: Integer);
  148.     procedure Grayscale(ForceEncoding: Boolean);
  149.     property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;
  150.     property Comment: TStrings read GetComment write SetComment;
  151.     property Corrupted: Boolean read GetCorrupted;
  152.     property Count: Integer read GetCount;
  153.     property Frames[Index: Integer]: TGIFFrame read GetFrame; default;
  154.     property FrameIndex: Integer read FFrameIndex write SetFrameIndex;
  155.     property GlobalColorCount: Integer read GetGlobalColorCount;
  156.     property Looping: Boolean read FLooping write SetLooping;
  157.     property PixelFormat: TPixelFormat read GetPixelFormat;
  158.     property RepeatCount: Word read FRepeatCount write SetRepeatCount;
  159.     property ScreenWidth: Integer read GetScreenWidth;
  160.     property ScreenHeight: Integer read GetScreenHeight;
  161.     property TransparentColor: TColor read GetTransparentColor;
  162.     property Version: TGIFVersion read FVersion;
  163. {$IFNDEF RX_D3}
  164.     property Palette: HPALETTE read GetPalette;
  165.     property Transparent: Boolean read GetTransparent;
  166.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  167. {$ENDIF}
  168.   end;
  169.  
  170. { TGIFFrame }
  171.  
  172.   TGIFFrame = class(TPersistent)
  173.   private
  174.     FOwner: TGIFImage;
  175.     FBitmap: TBitmap;
  176.     FImage: TGIFItem;
  177.     FExtensions: TList;
  178.     FTopLeft: TPoint;
  179.     FInterlaced: Boolean;
  180.     FCorrupted: Boolean;
  181.     FGrayscale: Boolean;
  182.     FTransparentColor: TColor;
  183.     FAnimateInterval: Word;
  184.     FDisposal: TDisposalMethod;
  185.     FLocalColors: Boolean;
  186.     function GetBitmap: TBitmap;
  187.     function GetHeight: Integer;
  188.     function GetWidth: Integer;
  189.     function GetColorCount: Integer;
  190.     function FindComment(ForceCreate: Boolean): TStrings;
  191.     function GetComment: TStrings;
  192.     procedure SetComment(Value: TStrings);
  193.     procedure SetTransparentColor(Value: TColor);
  194.     procedure SetDisposalMethod(Value: TDisposalMethod);
  195.     procedure SetAnimateInterval(Value: Word);
  196.     procedure SetTopLeft(const Value: TPoint);
  197.     procedure NewBitmap;
  198.     procedure NewImage;
  199.     procedure SaveToBitmapStream(Stream: TMemoryStream);
  200.     procedure EncodeBitmapStream(Stream: TMemoryStream);
  201.     procedure EncodeRasterData;
  202.     procedure UpdateExtensions;
  203.     procedure WriteImageDescriptor(Stream: TStream);
  204.     procedure WriteLocalColorMap(Stream: TStream);
  205.     procedure WriteRasterData(Stream: TStream);
  206.   protected
  207.     constructor Create(AOwner: TGIFImage); virtual;
  208.     procedure LoadFromStream(Stream: TStream);
  209.     procedure AssignTo(Dest: TPersistent); override;
  210.     procedure GrayscaleImage(ForceEncoding: Boolean);
  211.   public
  212.     destructor Destroy; override;
  213.     procedure Assign(Source: TPersistent); override;
  214.     procedure Draw(ACanvas: TCanvas; const ARect: TRect;
  215.       Transparent: Boolean);
  216.     property AnimateInterval: Word read FAnimateInterval write SetAnimateInterval;
  217.     property Bitmap: TBitmap read GetBitmap; { volatile }
  218.     property ColorCount: Integer read GetColorCount;
  219.     property Comment: TStrings read GetComment write SetComment;
  220.     property DisposalMethod: TDisposalMethod read FDisposal write SetDisposalMethod;
  221.     property Interlaced: Boolean read FInterlaced;
  222.     property Corrupted: Boolean read FCorrupted;
  223.     property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
  224.     property Origin: TPoint read FTopLeft write SetTopLeft;
  225.     property Height: Integer read GetHeight;
  226.     property Width: Integer read GetWidth;
  227.   end;
  228.  
  229. { TGIFData }
  230.  
  231.   TGIFData = class(TSharedImage)
  232.   private
  233.     FComment: TStrings;
  234.     FAspectRatio: Byte;
  235.     FBitsPerPixel: Byte;
  236.     FColorResBits: Byte;
  237.     FColorMap: TGIFColorTable;
  238.   protected
  239.     procedure FreeHandle; override;
  240.   public
  241.     constructor Create;
  242.     destructor Destroy; override;
  243.   end;
  244.  
  245. { TGIFItem }
  246.  
  247.   TGIFItem = class(TSharedImage)
  248.   private
  249.     FImageData: TMemoryStream;
  250.     FSize: TPoint;
  251.     FPackedFields: Byte;
  252.     FBitsPerPixel: Byte;
  253.     FColorMap: TGIFColorTable;
  254.   protected
  255.     procedure FreeHandle; override;
  256.   public
  257.     destructor Destroy; override;
  258.   end;
  259.  
  260. { Clipboard format for GIF image }
  261.  
  262. var
  263.   CF_GIF: Word;
  264.  
  265. { Load incomplete or corrupted images without exceptions }
  266.  
  267. const
  268.   GIFLoadCorrupted: Boolean = True;
  269.  
  270. function GIFVersionName(Version: TGIFVersion): string;
  271. procedure rxgif_dummy;
  272.  
  273. implementation
  274.  
  275. uses Consts, {$IFNDEF WIN32} Str16, {$ENDIF} VclUtils, AniFile, RxConst,
  276.   MaxMin, RxGConst;
  277.  
  278. {$R-}
  279.  
  280. procedure rxgif_dummy;
  281. begin
  282. end;
  283.  
  284. procedure GifError(const Msg: string);
  285. {$IFDEF WIN32}
  286.   function ReturnAddr: Pointer;
  287.   asm
  288.           MOV     EAX,[EBP+4]
  289.   end;
  290. {$ELSE}
  291.   function ReturnAddr: Pointer; assembler;
  292.   asm
  293.           MOV     AX,[BP].Word[2]
  294.           MOV     DX,[BP].Word[4]
  295.   end;
  296. {$ENDIF}
  297. begin
  298.   raise EInvalidGraphicOperation.Create(Msg) at ReturnAddr;
  299. end;
  300.  
  301. {$IFNDEF RX_D3}
  302.  
  303. { TSharedImage }
  304.  
  305. procedure TSharedImage.Reference;
  306. begin
  307.   Inc(FRefCount);
  308. end;
  309.  
  310. procedure TSharedImage.Release;
  311. begin
  312.   if Pointer(Self) <> nil then begin
  313.     Dec(FRefCount);
  314.     if FRefCount = 0 then begin
  315.       FreeHandle;
  316.       Free;
  317.     end;
  318.   end;
  319. end;
  320.  
  321. {$ENDIF}
  322.  
  323. const
  324.   GIFSignature = 'GIF';
  325.   GIFVersionStr: array[TGIFVersion] of PChar = (#0#0#0, '87a', '89a');
  326.  
  327. function GIFVersionName(Version: TGIFVersion): string;
  328. begin
  329.   Result := StrPas(GIFVersionStr[Version]);
  330. end;
  331.  
  332. const
  333.   CODE_TABLE_SIZE = 4096;
  334. {$IFDEF WIN32}
  335.   HASH_TABLE_SIZE = 17777;
  336. {$ELSE}
  337.   HASH_TABLE_SIZE = MaxListSize - $10;
  338. {$ENDIF}
  339.   MAX_LOOP_COUNT  = 30000;
  340.  
  341.   CHR_EXT_INTRODUCER    = '!';
  342.   CHR_IMAGE_SEPARATOR   = ',';
  343.   CHR_TRAILER           = ';';  { indicates the end of the GIF Data stream }
  344.  
  345. { Image descriptor bit masks }
  346.  
  347.   ID_LOCAL_COLOR_TABLE  = $80;  { set if a local color table follows }
  348.   ID_INTERLACED         = $40;  { set if image is interlaced }
  349.   ID_SORT               = $20;  { set if color table is sorted }
  350.   ID_RESERVED           = $0C;  { reserved - must be set to $00 }
  351.   ID_COLOR_TABLE_SIZE   = $07;  { Size of color table as above }
  352.  
  353. { Logical screen descriptor packed field masks }
  354.  
  355.   LSD_GLOBAL_COLOR_TABLE = $80; { set if global color table follows L.S.D. }
  356.   LSD_COLOR_RESOLUTION   = $70; { Color resolution - 3 bits }
  357.   LSD_SORT               = $08; { set if global color table is sorted - 1 bit }
  358.   LSD_COLOR_TABLE_SIZE   = $07; { Size of global color table - 3 bits }
  359.                                 { Actual Size = 2^value+1    - value is 3 bits }
  360.  
  361. { Graphic control extension packed field masks }
  362.  
  363.   GCE_TRANSPARENT     = $01; { whether a transparency Index is given }
  364.   GCE_USER_INPUT      = $02; { whether or not user input is expected }
  365.   GCE_DISPOSAL_METHOD = $1C; { the way in which the graphic is to be treated after being displayed }
  366.   GCE_RESERVED        = $E0; { reserved - must be set to $00 }
  367.  
  368. { Application extension }
  369.  
  370.   AE_LOOPING          = $01; { looping Netscape extension }
  371.  
  372.   GIFColors: array[TGIFBits] of Word = (2, 4, 8, 16, 32, 64, 128, 256);
  373.  
  374. function ColorsToBits(ColorCount: Word): Byte; near;
  375. var
  376.   I: TGIFBits;
  377. begin
  378.   Result := 0;
  379.   for I := Low(TGIFBits) to High(TGIFBits) do
  380.     if ColorCount = GIFColors[I] then begin
  381.       Result := I;
  382.       Exit;
  383.     end;
  384.   GifError(LoadStr(SWrongGIFColors));
  385. end;
  386.  
  387. function ColorsToPixelFormat(Colors: Word): TPixelFormat;
  388. begin
  389.   if Colors <= 2 then Result := pf1bit
  390.   else if Colors <= 16 then Result := pf4bit
  391.   else if Colors <= 256 then Result := pf8bit
  392.   else Result := pf24bit;
  393. end;
  394.  
  395. function ItemToRGB(Item: TGIFColorItem): Longint; near;
  396. begin
  397.   with Item do Result := RGB(Red, Green, Blue);
  398. end;
  399.  
  400. function GrayColor(Color: TColor): TColor;
  401. var
  402.   Index: Integer;
  403. begin
  404.   Index := Byte(Longint(Word(GetRValue(Color)) * 77 +
  405.     Word(GetGValue(Color)) * 150 + Word(GetBValue(Color)) * 29) shr 8);
  406.   Result := RGB(Index, Index, Index);
  407. end;
  408.  
  409. procedure GrayColorTable(var ColorTable: TGIFColorTable);
  410. var
  411.   I: Byte;
  412.   Index: Integer;
  413. begin
  414.   for I := 0 to ColorTable.Count - 1 do begin
  415.     with ColorTable.Colors[I] do begin
  416.       Index := Byte(Longint(Word(Red) * 77 + Word(Green) * 150 +
  417.         Word(Blue) * 29) shr 8);
  418.       Red := Index;
  419.       Green := Index;
  420.       Blue := Index;
  421.     end;
  422.   end;
  423. end;
  424.  
  425. function FindColorIndex(const ColorTable: TGIFColorTable;
  426.   Color: TColor): Integer;
  427. begin
  428.   if (Color <> clNone) then
  429.     for Result := 0 to ColorTable.Count - 1 do
  430.       if ItemToRGB(ColorTable.Colors[Result]) = ColorToRGB(Color) then Exit;
  431.   Result := -1;
  432. end;
  433.  
  434. { The following types and function declarations are used to call into
  435.   functions of the GIF implementation of the GIF image
  436.   compression/decompression standard. }
  437.  
  438. type
  439.   TGIFHeader = packed record
  440.     Signature: array[0..2] of Char; { contains 'GIF' }
  441.     Version: array[0..2] of Char;   { '87a' or '89a' }
  442.   end;
  443.  
  444.   TScreenDescriptor = packed record
  445.     ScreenWidth: Word;            { logical screen width }
  446.     ScreenHeight: Word;           { logical screen height }
  447.     PackedFields: Byte;
  448.     BackgroundColorIndex: Byte;   { Index to global color table }
  449.     AspectRatio: Byte;            { actual ratio = (AspectRatio + 15) / 64 }
  450.   end;
  451.  
  452.   TImageDescriptor = packed record
  453.     ImageLeftPos: Word;   { column in pixels in respect to left of logical screen }
  454.     ImageTopPos: Word;    { row in pixels in respect to top of logical screen }
  455.     ImageWidth: Word;     { width of image in pixels }
  456.     ImageHeight: Word;    { height of image in pixels }
  457.     PackedFields: Byte;
  458.   end;
  459.  
  460. { GIF Extensions support }
  461.  
  462. type
  463.   TExtensionType = (etGraphic, etPlainText, etApplication, etComment);
  464.  
  465. const
  466.   ExtLabels: array[TExtensionType] of Byte = ($F9, $01, $FF, $FE);
  467.   LoopExtNS: string[11] = 'NETSCAPE2.0';
  468.   LoopExtAN: string[11] = 'ANIMEXTS1.0';
  469.  
  470. type
  471.   TGraphicControlExtension = packed record
  472.     BlockSize: Byte; { should be 4 }
  473.     PackedFields: Byte;
  474.     DelayTime: Word; { in centiseconds }
  475.     TransparentColorIndex: Byte;
  476.     Terminator: Byte;
  477.   end;
  478.  
  479.   TPlainTextExtension = packed record
  480.     BlockSize: Byte; { should be 12 }
  481.     Left, Top, Width, Height: Word;
  482.     CellWidth, CellHeight: Byte;
  483.     FGColorIndex, BGColorIndex: Byte;
  484.   end;
  485.  
  486.   TAppExtension = packed record
  487.     BlockSize: Byte; { should be 11 }
  488.     AppId: array[1..8] of Byte;
  489.     Authentication: array[1..3] of Byte;
  490.   end;
  491.  
  492.   TExtensionRecord = packed record
  493.     case ExtensionType: TExtensionType of
  494.       etGraphic: (GCE: TGraphicControlExtension);
  495.       etPlainText: (PTE: TPlainTextExtension);
  496.       etApplication: (APPE: TAppExtension);
  497.   end;
  498.  
  499. { TExtension }
  500.  
  501.   TExtension = class(TPersistent)
  502.   private
  503.     FExtType: TExtensionType;
  504.     FData: TStrings;
  505.     FExtRec: TExtensionRecord;
  506.   public
  507.     destructor Destroy; override;
  508.     procedure Assign(Source: TPersistent); override;
  509.     function IsLoopExtension: Boolean;
  510.   end;
  511.  
  512. destructor TExtension.Destroy;
  513. begin
  514.   FData.Free;
  515.   inherited Destroy;
  516. end;
  517.  
  518. procedure TExtension.Assign(Source: TPersistent);
  519. begin
  520.   if (Source <> nil) and (Source is TExtension) then begin
  521.     FExtType := TExtension(Source).FExtType;
  522.     FExtRec := TExtension(Source).FExtRec;
  523.     if TExtension(Source).FData <> nil then begin
  524.       if FData = nil then FData := TStringList.Create;
  525.       FData.Assign(TExtension(Source).FData);
  526.     end;
  527.   end
  528.   else inherited Assign(Source);
  529. end;
  530.  
  531. function TExtension.IsLoopExtension: Boolean;
  532. begin
  533.   Result := (FExtType = etApplication) and (FData.Count > 0) and
  534.     (CompareMem(@FExtRec.APPE.AppId, @LoopExtNS[1], FExtRec.APPE.BlockSize) or
  535.     CompareMem(@FExtRec.APPE.AppId, @LoopExtAN[1], FExtRec.APPE.BlockSize)) and
  536.     (Length(FData[0]) >= 3) and (Byte(FData[0][1]) = AE_LOOPING);
  537. end;
  538.  
  539. procedure FreeExtensions(Extensions: TList); near;
  540. begin
  541.   if Extensions <> nil then begin
  542.     while Extensions.Count > 0 do begin
  543.       TObject(Extensions[0]).Free;
  544.       Extensions.Delete(0);
  545.     end;
  546.     Extensions.Free;
  547.   end;
  548. end;
  549.  
  550. function FindExtension(Extensions: TList; ExtType: TExtensionType): TExtension;
  551. var
  552.   I: Integer;
  553. begin
  554.   if Extensions <> nil then
  555.     for I := Extensions.Count - 1 downto 0 do begin
  556.       Result := TExtension(Extensions[I]);
  557.       if (Result <> nil) and (Result.FExtType = ExtType) then Exit;
  558.     end;
  559.   Result := nil;
  560. end;
  561.  
  562. {
  563. function CopyExtensions(Source: TList): TList; near;
  564. var
  565.   I: Integer;
  566.   Ext: TExtension;
  567. begin
  568.   Result := TList.Create;
  569.   try
  570.     for I := 0 to Source.Count - 1 do
  571.       if (Source[I] <> nil) and (TObject(Source[I]) is TExtension) then begin
  572.         Ext := TExtension.Create;
  573.         try
  574.           Ext.Assign(Source[I]);
  575.           Result.Add(Ext);
  576.         except
  577.           Ext.Free;
  578.           raise;
  579.         end;
  580.       end;
  581.   except
  582.     Result.Free;
  583.     raise;
  584.   end;
  585. end;
  586. }
  587.  
  588. type
  589.   TProgressProc = procedure (Stage: TProgressStage; PercentDone: Byte;
  590.     const Msg: string) of object;
  591.  
  592. { GIF reading/writing routines
  593.  
  594.   Procedures to read and write GIF files, GIF-decoding and encoding
  595.   based on freeware C source code of GBM package by Andy Key
  596.   (nyangau@interalpha.co.uk). The home page of GBM author is
  597.   at http://www.interalpha.net/customer/nyangau/. }
  598.  
  599. type
  600.   PIntCodeTable = ^TIntCodeTable;
  601.   TIntCodeTable = array[0..CODE_TABLE_SIZE - 1] of Word;
  602.  
  603.   PReadContext = ^TReadContext;
  604.   TReadContext = record
  605.     Inx, Size: Longint;
  606.     Buf: array[0..255 + 4] of Byte;
  607.     CodeSize: Longint;
  608.     ReadMask: Longint;
  609.   end;
  610.  
  611.   PWriteContext = ^TWriteContext;
  612.   TWriteContext = record
  613.     Inx: Longint;
  614.     CodeSize: Longint;
  615.     Buf: array[0..255 + 4] of Byte;
  616.   end;
  617.  
  618.   TOutputContext = record
  619.     W, H, X, Y: Longint;
  620.     BitsPerPixel, Pass: Integer;
  621.     Interlace: Boolean;
  622.     LineIdent: Longint;
  623.     Data, CurrLineData: Pointer;
  624.   end;
  625.  
  626.   PImageDict = ^TImageDict;
  627.   TImageDict = record
  628.     Tail, Index: Word;
  629.     Col: Byte;
  630.   end;
  631.  
  632.   PDictTable = ^TDictTable;
  633.   TDictTable = array[0..CODE_TABLE_SIZE - 1] of TImageDict;
  634.  
  635.   PRGBPalette = ^TRGBPalette;
  636.   TRGBPalette = array [Byte] of TRGBQuad;
  637.  
  638. function InitHash(P: Longint): Longint;
  639. begin
  640.   Result := (P + 3) * 301;
  641. end;
  642.  
  643. function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
  644. begin
  645.   Result := Y;
  646.   case Pass of
  647.     0, 1: Inc(Result, 8);
  648.     2: Inc(Result, 4);
  649.     3: Inc(Result, 2);
  650.   end;
  651.   if Result >= Height then begin
  652.     if Pass = 0 then begin
  653.       Pass := 1; Result := 4;
  654.       if (Result < Height) then Exit;
  655.     end;
  656.     if Pass = 1 then begin
  657.       Pass := 2; Result := 2;
  658.       if (Result < Height) then Exit;
  659.     end;
  660.     if Pass = 2 then begin
  661.       Pass := 3; Result := 1;
  662.     end;
  663.   end;
  664. end;
  665.  
  666. procedure ReadImageStream(Stream, Dest: TStream; var Desc: TImageDescriptor;
  667.   var Interlaced, LocalColors, Corrupted: Boolean; var BitsPerPixel: Byte;
  668.   var ColorTable: TGIFColorTable);
  669. var
  670.   CodeSize, BlockSize: Byte;
  671. begin
  672.   Corrupted := False;
  673.   Stream.ReadBuffer(Desc, SizeOf(TImageDescriptor));
  674.   Interlaced := (Desc.PackedFields and ID_INTERLACED) <> 0;
  675.   if (Desc.PackedFields and ID_LOCAL_COLOR_TABLE) <> 0 then
  676.   begin
  677.     { Local colors table follows }
  678.     BitsPerPixel := 1 + Desc.PackedFields and ID_COLOR_TABLE_SIZE;
  679.     LocalColors := True;
  680.     ColorTable.Count := 1 shl BitsPerPixel;
  681.     Stream.ReadBuffer(ColorTable.Colors[0],
  682.       ColorTable.Count * SizeOf(TGIFColorItem));
  683.   end
  684.   else begin
  685.     LocalColors := False;
  686.     FillChar(ColorTable, SizeOf(ColorTable), 0);
  687.   end;
  688.   Stream.ReadBuffer(CodeSize, 1);
  689.   Dest.Write(CodeSize, 1);
  690.   repeat
  691.     Stream.Read(BlockSize, 1);
  692.     if (Stream.Position + BlockSize) > Stream.Size then begin
  693.       Corrupted := True;
  694.       Stream.Position := Stream.Size;
  695.       Exit;
  696.     end;
  697.     Dest.Write(BlockSize, 1);
  698.     if (Stream.Position + BlockSize) > Stream.Size then begin
  699.       BlockSize := Stream.Size - Stream.Position;
  700.       Corrupted := True;
  701.     end;
  702.     if BlockSize > 0 then Dest.CopyFrom(Stream, BlockSize);
  703.   until (BlockSize = 0) or (Stream.Position >= Stream.Size);
  704. end;
  705.  
  706. procedure FillRGBPalette(const ColorTable: TGIFColorTable;
  707.   var Colors: TRGBPalette);
  708. var
  709.   I: Byte;
  710. begin
  711.   FillChar(Colors, SizeOf(Colors), $80);
  712.   for I := 0 to ColorTable.Count - 1 do begin
  713.     Colors[I].rgbRed := ColorTable.Colors[I].Red;
  714.     Colors[I].rgbGreen := ColorTable.Colors[I].Green;
  715.     Colors[I].rgbBlue := ColorTable.Colors[I].Blue;
  716.     Colors[I].rgbReserved := 0;
  717.   end;
  718. end;
  719.  
  720. function ReadCode(Stream: TStream; var Context: TReadContext): Longint;
  721. var
  722.   RawCode: Longint;
  723.   ByteIndex: Longint;
  724.   Bytes: Byte;
  725.   BytesToLose: Longint;
  726. begin
  727.   while (Context.Inx + Context.CodeSize > Context.Size) and
  728.     (Stream.Position < Stream.Size) do
  729.   begin
  730.     { not enough bits in buffer - refill it }
  731.     { Not very efficient, but infrequently called }
  732.     BytesToLose := Context.Inx shr 3;
  733.     { Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes }
  734.     Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
  735.     Context.Inx := Context.Inx and 7;
  736.     Context.Size := Context.Size - (BytesToLose shl 3);
  737.     Stream.ReadBuffer(Bytes, 1);
  738.     if Bytes > 0 then
  739.       Stream.ReadBuffer(Context.Buf[Word(Context.Size shr 3)], Bytes);
  740.     Context.Size := Context.Size + (Bytes shl 3);
  741.   end;
  742.   ByteIndex := Context.Inx shr 3;
  743.   RawCode := Context.Buf[Word(ByteIndex)] +
  744.     (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
  745.   if Context.CodeSize > 8 then
  746.     RawCode := RawCode + (Longint(Context.Buf[ByteIndex + 2]) shl 16);
  747.   RawCode := RawCode shr (Context.Inx and 7);
  748.   Context.Inx := Context.Inx + Byte(Context.CodeSize);
  749.   Result := RawCode and Context.ReadMask;
  750. end;
  751.  
  752. procedure Output(Value: Byte; var Context: TOutputContext);
  753. var
  754.   P: PByte;
  755. begin
  756.   if (Context.Y >= Context.H) then Exit;
  757.   case Context.BitsPerPixel of
  758.     1: begin
  759.          P := HugeOffset(Context.CurrLineData, Context.X shr 3);
  760.          if (Context.X and $07 <> 0) then
  761.            P^ := P^ or Word(value shl (7 - (Word(Context.X and 7))))
  762.          else P^ := Byte(value shl 7);
  763.        end;
  764.     4: begin
  765.          P := HugeOffset(Context.CurrLineData, Context.X shr 1);
  766.          if (Context.X and 1 <> 0) then P^ := P^ or Value
  767.          else P^ := Byte(value shl 4);
  768.        end;
  769.     8: begin
  770.          P := HugeOffset(Context.CurrLineData, Context.X);
  771.          P^ := Value;
  772.        end;
  773.   end;
  774.   Inc(Context.X);
  775.   if Context.X < Context.W then Exit;
  776.   Context.X := 0;
  777.   if Context.Interlace then
  778.     Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass)
  779.   else Inc(Context.Y);
  780.   Context.CurrLineData := HugeOffset(Context.Data,
  781.     (Context.H - 1 - Context.Y) * Context.LineIdent);
  782. end;
  783.  
  784. procedure ReadGIFData(Stream: TStream; const Header: TBitmapInfoHeader;
  785.   Interlaced, LoadCorrupt: Boolean; IntBitPerPixel: Byte; Data: Pointer;
  786.   var Corrupted: Boolean; ProgressProc: TProgressProc);
  787. var
  788.   MinCodeSize, Temp: Byte;
  789.   MaxCode, BitMask, InitCodeSize: Longint;
  790.   ClearCode, EndingCode, FirstFreeCode, FreeCode: Word;
  791.   I, OutCount, Code: Longint;
  792.   CurCode, OldCode, InCode, FinalChar: Word;
  793.   Prefix, Suffix, OutCode: PIntCodeTable;
  794.   ReadCtxt: TReadContext;
  795.   OutCtxt: TOutputContext;
  796.   TableFull: Boolean;
  797. begin
  798.   Corrupted := False;
  799.   OutCount := 0; OldCode := 0; FinalChar := 0;
  800.   TableFull := False;
  801.   Prefix := AllocMem(SizeOf(TIntCodeTable));
  802.   try
  803.     Suffix := AllocMem(SizeOf(TIntCodeTable));
  804.     try
  805.       OutCode := AllocMem(SizeOf(TIntCodeTable) + SizeOf(Word));
  806.       try
  807.         if Assigned(ProgressProc) then ProgressProc(psStarting, 0, '');
  808.         try
  809.           Stream.ReadBuffer(MinCodeSize, 1);
  810.           if (MinCodeSize < 2) or (MinCodeSize > 9) then begin
  811.             if LoadCorrupt then begin
  812.               Corrupted := True;
  813.               MinCodeSize := Max(2, Min(MinCodeSize, 9));
  814.             end
  815.             else GifError(LoadStr(SBadGIFCodeSize));
  816.           end;
  817.           { Initial read context }
  818.           ReadCtxt.Inx := 0;
  819.           ReadCtxt.Size := 0;
  820.           ReadCtxt.CodeSize := MinCodeSize + 1;
  821.           ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
  822.           { Initialise pixel-output context }
  823.           OutCtxt.X := 0; OutCtxt.Y := 0;
  824.           OutCtxt.Pass := 0;
  825.           OutCtxt.W := Header.biWidth;
  826.           OutCtxt.H := Header.biHeight;
  827.           OutCtxt.BitsPerPixel := Header.biBitCount;
  828.           OutCtxt.Interlace := Interlaced;
  829.           OutCtxt.LineIdent := ((Header.biWidth * Header.biBitCount + 31)
  830.             div 32) * 4;
  831.           OutCtxt.Data := Data;
  832.           OutCtxt.CurrLineData := HugeOffset(Data, (Header.biHeight - 1) *
  833.             OutCtxt.LineIdent);
  834.           BitMask := (1 shl IntBitPerPixel) - 1;
  835.           { 2 ^ MinCodeSize accounts for all colours in file }
  836.           ClearCode := 1 shl MinCodeSize;
  837.           EndingCode := ClearCode + 1;
  838.           FreeCode := ClearCode + 2;
  839.           FirstFreeCode := FreeCode;
  840.           { 2^ (MinCodeSize + 1) includes clear and eoi Code and space too }
  841.           InitCodeSize := ReadCtxt.CodeSize;
  842.           MaxCode := 1 shl ReadCtxt.CodeSize;
  843.           Code := ReadCode(Stream, ReadCtxt);
  844.           while (Code <> EndingCode) and (Code <> $FFFF) and
  845.             (OutCtxt.Y < OutCtxt.H) do
  846.           begin
  847.             if (Code = ClearCode) then begin
  848.               ReadCtxt.CodeSize := InitCodeSize;
  849.               MaxCode := 1 shl ReadCtxt.CodeSize;
  850.               ReadCtxt.ReadMask := MaxCode - 1;
  851.               FreeCode := FirstFreeCode;
  852.               Code := ReadCode(Stream, ReadCtxt);
  853.               CurCode := Code; OldCode := Code;
  854.               if (Code = $FFFF) then Break;
  855.               FinalChar := (CurCode and BitMask);
  856.               Output(Byte(FinalChar), OutCtxt);
  857.               TableFull := False;
  858.             end
  859.             else begin
  860.               CurCode := Code;
  861.               InCode := Code;
  862.               if CurCode >= FreeCode then begin
  863.                 CurCode := OldCode;
  864.                 OutCode^[OutCount] := FinalChar;
  865.                 Inc(OutCount);
  866.               end;
  867.               while (CurCode > BitMask) do begin
  868.                 if (OutCount > CODE_TABLE_SIZE) then begin
  869.                   if LoadCorrupt then begin
  870.                     CurCode := BitMask;
  871.                     OutCount := 1;
  872.                     Corrupted := True;
  873.                     Break;
  874.                   end
  875.                   else GifError(LoadStr(SGIFDecodeError));
  876.                 end;
  877.                 OutCode^[OutCount] := Suffix^[CurCode];
  878.                 Inc(OutCount);
  879.                 CurCode := Prefix^[CurCode];
  880.               end;
  881.               if Corrupted then Break;
  882.               FinalChar := CurCode and BitMask;
  883.               OutCode^[OutCount] := FinalChar;
  884.               Inc(OutCount);
  885.               for I := OutCount - 1 downto 0 do
  886.                 Output(Byte(OutCode^[I]), OutCtxt);
  887.               OutCount := 0;
  888.               { Update dictionary }
  889.               if not TableFull then begin
  890.                 Prefix^[FreeCode] := OldCode;
  891.                 Suffix^[FreeCode] := FinalChar;
  892.                 { Advance to next free slot }
  893.                 Inc(FreeCode);
  894.                 if (FreeCode >= MaxCode) then begin
  895.                   if (ReadCtxt.CodeSize < 12) then begin
  896.                     Inc(ReadCtxt.CodeSize);
  897.                     MaxCode := MaxCode shl 1;
  898.                     ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
  899.                   end
  900.                   else TableFull := True;
  901.                 end;
  902.               end;
  903.               OldCode := InCode;
  904.             end;
  905.             Code := ReadCode(Stream, ReadCtxt);
  906.             if Stream.Size > 0 then begin
  907.               Temp := Trunc(100.0 * (Stream.Position / Stream.Size));
  908.               if Assigned(ProgressProc) then ProgressProc(psRunning, Temp, '');
  909.             end;
  910.           end; { while }
  911.           if Code = $FFFF then GifError(ResStr(SReadError));
  912.         finally
  913.           if Assigned(ProgressProc) then begin
  914.             if ExceptObject = nil then ProgressProc(psEnding, 100, '')
  915.             else ProgressProc(psEnding, 0, Exception(ExceptObject).Message);
  916.           end;
  917.         end;
  918.       finally
  919.         FreeMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
  920.       end;
  921.     finally
  922.       FreeMem(Suffix, SizeOf(TIntCodeTable));
  923.     end;
  924.   finally
  925.     FreeMem(Prefix, SizeOf(TIntCodeTable));
  926.   end;
  927. end;
  928.  
  929. procedure WriteCode(Stream: TStream; Code: Longint;
  930.   var Context: TWriteContext);
  931. var
  932.   BufIndex: Longint;
  933.   Bytes: Byte;
  934. begin
  935.   BufIndex := Context.Inx shr 3;
  936.   Code := Code shl (Context.Inx and 7);
  937.   Context.Buf[BufIndex] := Context.Buf[BufIndex] or (Code);
  938.   Context.Buf[BufIndex + 1] := (Code shr 8);
  939.   Context.Buf[BufIndex + 2] := (Code shr 16);
  940.   Context.Inx := Context.Inx + Context.CodeSize;
  941.   if Context.Inx >= 255 * 8 then begin
  942.     { Flush out full buffer }
  943.     Bytes := 255;
  944.     Stream.WriteBuffer(Bytes, 1);
  945.     Stream.WriteBuffer(Context.Buf, Bytes);
  946.     Move(Context.Buf[255], Context.Buf[0], 2);
  947.     FillChar(Context.Buf[2], 255, 0);
  948.     Context.Inx := Context.Inx - (255 * 8);
  949.   end;
  950. end;
  951.  
  952. procedure FlushCode(Stream: TStream; var Context: TWriteContext);
  953. var
  954.   Bytes: Byte;
  955. begin
  956.   Bytes := (Context.Inx + 7) shr 3;
  957.   if Bytes > 0 then begin
  958.     Stream.WriteBuffer(Bytes, 1);
  959.     Stream.WriteBuffer(Context.Buf, Bytes);
  960.   end;
  961.   { Data block terminator - a block of zero Size }
  962.   Bytes := 0;
  963.   Stream.WriteBuffer(Bytes, 1);
  964. end;
  965.  
  966. procedure FillColorTable(var ColorTable: TGIFColorTable;
  967.   const Colors: TRGBPalette; Count: Integer);
  968. var
  969.   I: Byte;
  970. begin
  971.   FillChar(ColorTable, SizeOf(ColorTable), 0);
  972.   ColorTable.Count := Min(256, Count);
  973.   for I := 0 to ColorTable.Count - 1 do begin
  974.     ColorTable.Colors[I].Red := Colors[I].rgbRed;
  975.     ColorTable.Colors[I].Green := Colors[I].rgbGreen;
  976.     ColorTable.Colors[I].Blue := Colors[I].rgbBlue;
  977.   end;
  978. end;
  979.  
  980. procedure WriteGIFData(Stream: TStream; var Header: TBitmapInfoHeader;
  981.   Interlaced: Boolean; Data: Pointer; ProgressProc: TProgressProc);
  982.   { LZW encode data }
  983. var
  984.   LineIdent: Longint;
  985.   MinCodeSize, Col, Temp: Byte;
  986.   InitCodeSize, X, Y: Longint;
  987.   Pass: Integer;
  988.   MaxCode: Longint; { 1 shl CodeSize }
  989.   ClearCode, EndingCode, LastCode, Tail: Longint;
  990.   I, HashValue: Longint;
  991.   LenString: Word;
  992.   Dict: PDictTable;
  993.   HashTable: TList;
  994.   PData: PByte;
  995.   WriteCtxt: TWriteContext;
  996. begin
  997.   LineIdent := ((Header.biWidth * Header.biBitCount + 31) div 32) * 4;
  998.   Tail := 0; HashValue := 0;
  999.   Dict := AllocMem(SizeOf(TDictTable));
  1000.   try
  1001.     HashTable := TList.Create;
  1002.     try
  1003.       for I := 0 to HASH_TABLE_SIZE - 1 do HashTable.Add(nil);
  1004.       { Initialise encoder variables }
  1005.       InitCodeSize := Header.biBitCount + 1;
  1006.       if InitCodeSize = 2 then Inc(InitCodeSize);
  1007.       MinCodeSize := InitCodeSize - 1;
  1008.       Stream.WriteBuffer(MinCodeSize, 1);
  1009.       ClearCode := 1 shl MinCodeSize;
  1010.       EndingCode := ClearCode + 1;
  1011.       LastCode := EndingCode;
  1012.       MaxCode := 1 shl InitCodeSize;
  1013.       LenString := 0;
  1014.       { Setup write context }
  1015.       WriteCtxt.Inx := 0;
  1016.       WriteCtxt.CodeSize := InitCodeSize;
  1017.       FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);
  1018.       WriteCode(Stream, ClearCode, WriteCtxt);
  1019.       for I := 0 to HASH_TABLE_SIZE - 1 do HashTable[I] := nil;
  1020.       Data := HugeOffset(Data, (Header.biHeight - 1) * LineIdent);
  1021.       Y := 0; Pass := 0;
  1022.       if Assigned(ProgressProc) then ProgressProc(psStarting, 0, '');
  1023.       try
  1024.         while (Y < Header.biHeight) do begin
  1025.           PData := HugeOffset(Data, -(Y * LineIdent));
  1026.           for X := 0 to Header.biWidth - 1 do begin
  1027.             case Header.biBitCount of
  1028.               8: begin
  1029.                    Col := PData^;
  1030.                    PData := HugeOffset(PData, 1);
  1031.                  end;
  1032.               4: begin
  1033.                    if X and 1 <> 0 then begin
  1034.                      Col := PData^ and $0F;
  1035.                      PData := HugeOffset(PData, 1);
  1036.                    end
  1037.                    else Col := PData^ shr 4;
  1038.                  end;
  1039.               else { must be 1 }
  1040.                 begin
  1041.                   if X and 7 = 7 then begin
  1042.                     Col := PData^ and 1;
  1043.                     PData := HugeOffset(PData, 1);
  1044.                   end
  1045.                   else Col := (PData^ shr (7 - (X and $07))) and $01;
  1046.                 end;
  1047.             end; { case }
  1048.             Inc(LenString);
  1049.             if LenString = 1 then begin
  1050.               Tail := Col;
  1051.               HashValue := InitHash(Col);
  1052.             end
  1053.             else begin
  1054.               HashValue := HashValue * (Col + LenString + 4);
  1055.               I := HashValue mod HASH_TABLE_SIZE;
  1056.               HashValue := HashValue mod HASH_TABLE_SIZE;
  1057.               while (HashTable[I] <> nil) and
  1058.                 ((PImageDict(HashTable[I])^.Tail <> Tail) or
  1059.                 (PImageDict(HashTable[I])^.Col <> Col)) do
  1060.               begin
  1061.                 Inc(I);
  1062.                 if (I >= HASH_TABLE_SIZE) then I := 0;
  1063.               end;
  1064.               if (HashTable[I] <> nil) then { Found in the strings table }
  1065.                 Tail := PImageDict(HashTable[I])^.Index
  1066.               else begin
  1067.                 { Not found }
  1068.                 WriteCode(Stream, Tail, WriteCtxt);
  1069.                 Inc(LastCode);
  1070.                 HashTable[I] := @Dict^[LastCode];
  1071.                 PImageDict(HashTable[I])^.Index := LastCode;
  1072.                 PImageDict(HashTable[I])^.Tail := Tail;
  1073.                 PImageDict(HashTable[I])^.Col := Col;
  1074.                 Tail := Col;
  1075.                 HashValue := InitHash(Col);
  1076.                 LenString := 1;
  1077.                 if (LastCode >= MaxCode) then begin
  1078.                   { Next Code will be written longer }
  1079.                   MaxCode := MaxCode shl 1;
  1080.                   Inc(WriteCtxt.CodeSize);
  1081.                 end
  1082.                 else if (LastCode >= CODE_TABLE_SIZE - 2) then begin
  1083.                   { Reset tables }
  1084.                   WriteCode(Stream, Tail, WriteCtxt);
  1085.                   WriteCode(Stream, ClearCode, WriteCtxt);
  1086.                   LenString := 0;
  1087.                   LastCode := EndingCode;
  1088.                   WriteCtxt.CodeSize := InitCodeSize;
  1089.                   MaxCode := 1 shl InitCodeSize;
  1090.                   for I := 0 to HASH_TABLE_SIZE - 1 do HashTable[I] := nil;
  1091.                 end;
  1092.               end;
  1093.             end;
  1094.           end; { for X loop }
  1095.           if Interlaced then Y := InterlaceStep(Y, Header.biHeight, Pass)
  1096.           else Inc(Y);
  1097.           Temp := Trunc(100.0 * (Y / Header.biHeight));
  1098.           if Assigned(ProgressProc) then ProgressProc(psRunning, Temp, '');
  1099.         end; { while Y loop }
  1100.         WriteCode(Stream, Tail, WriteCtxt);
  1101.         WriteCode(Stream, EndingCode, WriteCtxt);
  1102.         FlushCode(Stream, WriteCtxt);
  1103.       finally
  1104.         if Assigned(ProgressProc) then begin
  1105.           if ExceptObject = nil then ProgressProc(psEnding, 100, '')
  1106.           else ProgressProc(psEnding, 0, Exception(ExceptObject).Message);
  1107.         end;
  1108.       end;
  1109.     finally
  1110.       HashTable.Free;
  1111.     end;
  1112.   finally
  1113.     FreeMem(Dict, SizeOf(TDictTable));
  1114.   end;
  1115. end;
  1116.  
  1117. { TGIFItem }
  1118.  
  1119. destructor TGIFItem.Destroy;
  1120. begin
  1121.   FImageData.Free;
  1122.   inherited Destroy;
  1123. end;
  1124.  
  1125. procedure TGIFItem.FreeHandle;
  1126. begin
  1127.   if FImageData <> nil then FImageData.SetSize(0);
  1128. end;
  1129.  
  1130. { TGIFData }
  1131.  
  1132. constructor TGIFData.Create;
  1133. begin
  1134.   inherited Create;
  1135.   FComment := TStringList.Create;
  1136. end;
  1137.  
  1138. destructor TGIFData.Destroy;
  1139. begin
  1140.   FComment.Free;
  1141.   inherited Destroy;
  1142. end;
  1143.  
  1144. procedure TGIFData.FreeHandle;
  1145. begin
  1146.   if FComment <> nil then FComment.Clear;
  1147. end;
  1148.  
  1149. { TGIFFrame }
  1150.  
  1151. constructor TGIFFrame.Create(AOwner: TGIFImage);
  1152. begin
  1153.   FOwner := AOwner;
  1154.   inherited Create;
  1155.   NewImage;
  1156. end;
  1157.  
  1158. destructor TGIFFrame.Destroy;
  1159. begin
  1160.   FBitmap.Free;
  1161.   FreeExtensions(FExtensions);
  1162.   FImage.Release;
  1163.   inherited Destroy;
  1164. end;
  1165.  
  1166. procedure TGIFFrame.SetAnimateInterval(Value: Word);
  1167. begin
  1168.   if FAnimateInterval <> Value then begin
  1169.     FAnimateInterval := Value;
  1170.     if Value > 0 then FOwner.FVersion := gv89a;
  1171.     FOwner.Changed(FOwner);
  1172.   end;
  1173. end;
  1174.  
  1175. procedure TGIFFrame.SetDisposalMethod(Value: TDisposalMethod);
  1176. begin
  1177.   if FDisposal <> Value then begin
  1178.     FDisposal := Value;
  1179.     if Value <> dmUndefined then FOwner.FVersion := gv89a;
  1180.     FOwner.Changed(FOwner);
  1181.   end;
  1182. end;
  1183.  
  1184. procedure TGIFFrame.SetTopLeft(const Value: TPoint);
  1185. begin
  1186.   if (FTopLeft.X <> Value.X) or (FTopLeft.Y <> Value.Y) then begin
  1187.     FTopLeft.X := Value.X;
  1188.     FTopLeft.Y := Value.Y;
  1189.     FOwner.FScreenWidth := Max(FOwner.FScreenWidth,
  1190.       FImage.FSize.X + FTopLeft.X);
  1191.     FOwner.FScreenHeight := Max(FOwner.FScreenHeight,
  1192.       FImage.FSize.Y + FTopLeft.Y);
  1193.     FOwner.Changed(FOwner);
  1194.   end;
  1195. end;
  1196.  
  1197. procedure TGIFFrame.SetTransparentColor(Value: TColor);
  1198. begin
  1199.   if FTransparentColor <> Value then begin
  1200.     FTransparentColor := Value;
  1201.     if Value <> clNone then FOwner.FVersion := gv89a;
  1202.     FOwner.Changed(FOwner);
  1203.   end;
  1204. end;
  1205.  
  1206. function TGIFFrame.GetBitmap: TBitmap;
  1207. var
  1208.   Mem: TMemoryStream;
  1209. begin
  1210.   Result := FBitmap;
  1211.   if (Result = nil) or Result.Empty then begin
  1212.     NewBitmap;
  1213.     Result := FBitmap;
  1214.     if Assigned(FImage.FImageData) then
  1215.     try
  1216.       Mem := TMemoryStream.Create;
  1217.       try
  1218.         SaveToBitmapStream(Mem);
  1219.         FBitmap.LoadFromStream(Mem);
  1220. {$IFDEF RX_D3}
  1221.         if not FBitmap.Monochrome then FBitmap.HandleType := bmDDB;
  1222. {$ENDIF}
  1223.       finally
  1224.         Mem.Free;
  1225.       end;
  1226.     except
  1227.       raise;
  1228.     end;
  1229.   end;
  1230. end;
  1231.  
  1232. function TGIFFrame.GetHeight: Integer;
  1233. begin
  1234.   if Assigned(FBitmap) or Assigned(FImage.FImageData) then
  1235.     Result := Bitmap.Height
  1236.   else Result := 0;
  1237. end;
  1238.  
  1239. function TGIFFrame.GetWidth: Integer;
  1240. begin
  1241.   if Assigned(FBitmap) or Assigned(FImage.FImageData) then
  1242.     Result := Bitmap.Width
  1243.   else Result := 0;
  1244. end;
  1245.  
  1246. function TGIFFrame.GetColorCount: Integer;
  1247. begin
  1248.   Result := FImage.FColormap.Count;
  1249.   if (Result = 0) and Assigned(FBitmap) and (FBitmap.Palette <> 0) then
  1250.     Result := PaletteEntries(FBitmap.Palette);
  1251. end;
  1252.  
  1253. procedure TGIFFrame.GrayscaleImage(ForceEncoding: Boolean);
  1254. var
  1255.   Mem: TMemoryStream;
  1256.   TransIndex: Integer;
  1257. begin
  1258.   if not FGrayscale and (Assigned(FBitmap) or
  1259.     Assigned(FImage.FImageData)) then
  1260.   begin
  1261.     if Assigned(FImage.FImageData) and (FImage.FColorMap.Count > 0) then begin
  1262.       FBitmap.Free;
  1263.       FBitmap := nil;
  1264.       TransIndex := FindColorIndex(FImage.FColorMap, FTransparentColor);
  1265.       GrayColorTable(FImage.FColorMap);
  1266.       if TransIndex >= 0 then
  1267.         FTransparentColor := ItemToRGB(FImage.FColorMap.Colors[TransIndex])
  1268.       else FTransparentColor := clNone;
  1269.       FGrayscale := True;
  1270.       try
  1271.         GetBitmap;
  1272.       except
  1273.         on EAbort do;
  1274.         else raise;
  1275.       end;
  1276.     end
  1277.     else begin
  1278.       Mem := BitmapToMemoryStream(Bitmap, pf8bit, mmGrayscale);
  1279.       try
  1280.         FImage.Release;
  1281.         FImage := TGIFItem.Create;
  1282.         FImage.Reference;
  1283.         if ForceEncoding then EncodeBitmapStream(Mem);
  1284.         FGrayscale := True;
  1285.         if FTransparentColor <> clNone then
  1286.           FTransparentColor := GrayColor(FTransparentColor);
  1287.         FBitmap.LoadFromStream(Mem);
  1288.       finally
  1289.         Mem.Free;
  1290.       end;
  1291.     end;
  1292.   end;
  1293. end;
  1294.  
  1295. procedure TGIFFrame.Assign(Source: TPersistent);
  1296. var
  1297.   AComment: TStrings;
  1298. begin
  1299.   if Source = nil then begin
  1300.     NewImage;
  1301.     FBitmap.Free;
  1302.     FBitmap := nil;
  1303.   end
  1304.   else if (Source is TGIFFrame) then begin
  1305.     if Source <> Self then begin
  1306.       FImage.Release;
  1307.       FImage := TGIFFrame(Source).FImage;
  1308.       if TGIFFrame(Source).FOwner <> FOwner then FLocalColors := True
  1309.       else FLocalColors := TGIFFrame(Source).FLocalColors;
  1310.       FImage.Reference;
  1311.       FTopLeft := TGIFFrame(Source).FTopLeft;
  1312.       FInterlaced := TGIFFrame(Source).FInterlaced;
  1313.       if TGIFFrame(Source).FBitmap <> nil then begin
  1314.         NewBitmap;
  1315.         FBitmap.Assign(TGIFFrame(Source).FBitmap);
  1316.       end;
  1317.       FTransparentColor := TGIFFrame(Source).FTransparentColor;
  1318.       FAnimateInterval := TGIFFrame(Source).FAnimateInterval;
  1319.       FDisposal := TGIFFrame(Source).FDisposal;
  1320.       FGrayscale := TGIFFrame(Source).FGrayscale;
  1321.       FCorrupted := TGIFFrame(Source).FCorrupted;
  1322.       AComment := TGIFFrame(Source).FindComment(False);
  1323.       if (AComment <> nil) and (AComment.Count > 0) then
  1324.         SetComment(AComment);
  1325.     end;
  1326.   end
  1327.   else if Source is TGIFImage then begin
  1328.     if (TGIFImage(Source).Count > 0) then begin
  1329.       if (TGIFImage(Source).FrameIndex >= 0) then
  1330.         Assign(TGIFImage(Source).Frames[TGIFImage(Source).FrameIndex])
  1331.       else
  1332.         Assign(TGIFImage(Source).Frames[0]);
  1333.     end
  1334.     else Assign(nil);
  1335.   end
  1336.   else if Source is TGraphic then begin
  1337.     { TBitmap, TJPEGImage... }
  1338.     if TGraphic(Source).Empty then begin
  1339.       Assign(nil);
  1340.       Exit;
  1341.     end;
  1342.     NewImage;
  1343.     NewBitmap;
  1344.     try
  1345.       FBitmap.Assign(Source);
  1346.       if Source is TBitmap then
  1347.         FBitmap.Monochrome := TBitmap(Source).Monochrome;
  1348.     except
  1349.       FBitmap.Canvas.Brush.Color := clFuchsia;
  1350.       FBitmap.Width := TGraphic(Source).Width;
  1351.       FBitmap.Height := TGraphic(Source).Height;
  1352.       FBitmap.Canvas.Draw(0, 0, TGraphic(Source));
  1353.     end;
  1354. {$IFDEF RX_D3}
  1355.     if TGraphic(Source).Transparent then begin
  1356.       if Source is TBitmap then
  1357.         FTransparentColor := TBitmap(Source).TransparentColor
  1358.       else FTransparentColor := GetNearestColor(FBitmap.Canvas.Handle,
  1359.         ColorToRGB(FBitmap.Canvas.Brush.Color));
  1360.     end;
  1361. {$ELSE}
  1362.     if (Source is TIcon) or (Source is TMetafile) then
  1363.       FTransparentColor := GetNearestColor(FBitmap.Canvas.Handle,
  1364.         ColorToRGB(FBitmap.Canvas.Brush.Color));
  1365. {$ENDIF}
  1366.   end
  1367.   else inherited Assign(Source);
  1368.   if FOwner <> nil then FOwner.UpdateScreenSize;
  1369. end;
  1370.  
  1371. procedure TGIFFrame.AssignTo(Dest: TPersistent);
  1372. begin
  1373.   if (Dest is TGIFFrame) or (Dest is TGIFImage) then Dest.Assign(Self)
  1374.   else if Dest is TGraphic then begin
  1375.     Dest.Assign(Bitmap);
  1376. {$IFDEF RX_D3}
  1377.     if (Dest is TBitmap) and (FTransparentColor <> clNone) then begin
  1378.       TBitmap(Dest).TransparentColor := GetNearestColor(
  1379.         TBitmap(Dest).Canvas.Handle, ColorToRGB(FTransparentColor));
  1380.       TBitmap(Dest).Transparent := True;
  1381.     end;
  1382. {$ENDIF}
  1383.   end
  1384.   else inherited AssignTo(Dest);
  1385. end;
  1386.  
  1387. procedure TGIFFrame.NewBitmap;
  1388. begin
  1389.   FBitmap.Free;
  1390.   FBitmap := TBitmap.Create;
  1391. end;
  1392.  
  1393. procedure TGIFFrame.NewImage;
  1394. begin
  1395.   if FImage <> nil then FImage.Release;
  1396.   FImage := TGIFItem.Create;
  1397.   FImage.Reference;
  1398.   FGrayscale := False;
  1399.   FCorrupted := False;
  1400.   FTransparentColor := clNone;
  1401.   FTopLeft := Point(0, 0);
  1402.   FInterlaced := False;
  1403.   FLocalColors := False;
  1404.   FAnimateInterval := 0;
  1405.   FDisposal := dmUndefined;
  1406. end;
  1407.  
  1408. function TGIFFrame.FindComment(ForceCreate: Boolean): TStrings;
  1409. var
  1410.   Ext: TExtension;
  1411. begin
  1412.   Ext := FindExtension(FExtensions, etComment);
  1413.   if (Ext = nil) and ForceCreate then begin
  1414.     Ext := TExtension.Create;
  1415.     try
  1416.       Ext.FExtType := etComment;
  1417.       if FExtensions = nil then FExtensions := TList.Create;
  1418.       FExtensions.Add(Ext);
  1419.     except
  1420.       Ext.Free;
  1421.       raise;
  1422.     end;
  1423.   end;
  1424.   if (Ext <> nil) then begin
  1425.     if (Ext.FData = nil) and ForceCreate then
  1426.       Ext.FData := TStringList.Create;
  1427.     Result := Ext.FData;
  1428.   end
  1429.   else Result := nil;
  1430. end;
  1431.  
  1432. function TGIFFrame.GetComment: TStrings;
  1433. begin
  1434.   Result := FindComment(True);
  1435. end;
  1436.  
  1437. procedure TGIFFrame.SetComment(Value: TStrings);
  1438. begin
  1439.   GetComment.Assign(Value);
  1440. end;
  1441.  
  1442. procedure TGIFFrame.UpdateExtensions;
  1443. var
  1444.   Ext: TExtension;
  1445.   I: Integer;
  1446. begin
  1447.   Ext := FindExtension(FExtensions, etGraphic);
  1448.   if (FAnimateInterval > 0) or (FTransparentColor <> clNone) or
  1449.     (FDisposal <> dmUndefined) then
  1450.   begin
  1451.     if Ext = nil then begin
  1452.       Ext := TExtension.Create;
  1453.       Ext.FExtType := etGraphic;
  1454.       if FExtensions = nil then FExtensions := TList.Create;
  1455.       FExtensions.Add(Ext);
  1456.       with Ext.FExtRec.GCE do begin
  1457.         BlockSize := 4;
  1458.         PackedFields := 0;
  1459.         Terminator := 0;
  1460.       end;
  1461.     end;
  1462.   end;
  1463.   if Ext <> nil then
  1464.     with Ext.FExtRec.GCE do begin
  1465.       DelayTime := FAnimateInterval div 10;
  1466.       I := FindColorIndex(FImage.FColorMap, FTransparentColor);
  1467.       if I >= 0 then begin
  1468.         TransparentColorIndex := I;
  1469.         PackedFields := PackedFields or GCE_TRANSPARENT;
  1470.       end
  1471.       else PackedFields := PackedFields and not GCE_TRANSPARENT;
  1472.       PackedFields := (PackedFields and not GCE_DISPOSAL_METHOD) or
  1473.         (Ord(FDisposal) shl 2);
  1474.     end;
  1475.   if FExtensions <> nil then
  1476.     for I := FExtensions.Count - 1 downto 0 do begin
  1477.       Ext := TExtension(FExtensions[I]);
  1478.       if (Ext <> nil) and (Ext.FExtType = etComment) and
  1479.         ((Ext.FData = nil) or (Ext.FData.Count = 0)) then
  1480.       begin
  1481.         Ext.Free;
  1482.         FExtensions.Delete(I);
  1483.       end;
  1484.     end;
  1485.   if (FExtensions <> nil) and (FExtensions.Count > 0) then
  1486.     FOwner.FVersion := gv89a;
  1487. end;
  1488.  
  1489. procedure TGIFFrame.EncodeBitmapStream(Stream: TMemoryStream);
  1490. var
  1491.   BI: PBitmapInfoHeader;
  1492.   ColorCount, W, H: Integer;
  1493.   Bits, Pal: Pointer;
  1494. begin
  1495.   ColorCount := 0;
  1496.   Stream.Position := 0;
  1497.   BI := PBitmapInfoHeader(Longint(Stream.Memory) + SizeOf(TBitmapFileHeader));
  1498.   W := BI^.biWidth; H := BI^.biHeight;
  1499.   Pal := PRGBPalette(Longint(BI) + SizeOf(TBitmapInfoHeader));
  1500.   Bits := Pointer(Longword(Stream.Memory) + PBitmapFileHeader(Stream.Memory)^.bfOffBits);
  1501.   case BI^.biBitCount of
  1502.     1: ColorCount := 2;
  1503.     4: ColorCount := 16;
  1504.     8: ColorCount := 256;
  1505.     else GifError(LoadStr(SGIFEncodeError));
  1506.   end;
  1507.   FInterlaced := False;
  1508.   FillColorTable(FImage.FColorMap, PRGBPalette(Pal)^, ColorCount);
  1509.   if FImage.FImageData = nil then FImage.FImageData := TMemoryStream.Create
  1510.   else FImage.FImageData.SetSize(0);
  1511.   try
  1512.     WriteGIFData(FImage.FImageData, BI^, FInterlaced, Bits, FOwner.DoProgress);
  1513.   except
  1514.     on EAbort do begin
  1515.       NewImage; { OnProgress can raise EAbort to cancel image save }
  1516.       raise;
  1517.     end
  1518.     else raise;
  1519.   end;
  1520.   FImage.FBitsPerPixel := 1;
  1521.   while FImage.FColorMap.Count > 1 shl FImage.FBitsPerPixel do
  1522.     Inc(FImage.FBitsPerPixel);
  1523.   if FOwner.FImage.FColorMap.Count = 0 then begin
  1524.     FOwner.FImage.FColorMap := FImage.FColorMap;
  1525.     FOwner.FImage.FBitsPerPixel := FImage.FBitsPerPixel;
  1526.     FLocalColors := False;
  1527.   end
  1528.   else FLocalColors := True;
  1529.   FImage.FSize.X := W; FImage.FSize.Y := H;
  1530.   FOwner.FScreenWidth := Max(FOwner.FScreenWidth, FImage.FSize.X + FTopLeft.X);
  1531.   FOwner.FScreenHeight := Max(FOwner.FScreenHeight, FImage.FSize.Y + FTopLeft.Y);
  1532. end;
  1533.  
  1534. procedure TGIFFrame.EncodeRasterData;
  1535. var
  1536.   Method: TMappingMethod;
  1537.   Mem: TMemoryStream;
  1538. begin
  1539.   if not Assigned(FBitmap) or FBitmap.Empty then GifError(LoadStr(SNoGIFData));
  1540.   if not (GetBitmapPixelFormat(FBitmap) in [pf1bit, pf4bit, pf8bit]) then
  1541.   begin
  1542.     if FGrayscale then Method := mmGrayscale
  1543.     else Method := DefaultMappingMethod;
  1544.     Mem := BitmapToMemoryStream(FBitmap, pf8bit, Method);
  1545.     if (Method = mmGrayscale) then FGrayscale := True;
  1546.   end
  1547.   else Mem := TMemoryStream.Create;
  1548.   try
  1549.     if Mem.Size = 0 then FBitmap.SaveToStream(Mem);
  1550.     EncodeBitmapStream(Mem);
  1551.   finally
  1552.     Mem.Free;
  1553.   end;
  1554. end;
  1555.  
  1556. procedure TGIFFrame.WriteImageDescriptor(Stream: TStream);
  1557. var
  1558.   ImageDesc: TImageDescriptor;
  1559. begin
  1560.   with ImageDesc do begin
  1561.     PackedFields := 0;
  1562.     if FLocalColors then begin
  1563.       FImage.FBitsPerPixel := 1;
  1564.       while FImage.FColorMap.Count > 1 shl FImage.FBitsPerPixel do
  1565.         Inc(FImage.FBitsPerPixel);
  1566.       PackedFields := (PackedFields or ID_LOCAL_COLOR_TABLE) +
  1567.         (FImage.FBitsPerPixel - 1);
  1568.     end;
  1569.     if FInterlaced then PackedFields := PackedFields or ID_INTERLACED;
  1570.     ImageLeftPos := FTopLeft.X;
  1571.     ImageTopPos := FTopLeft.Y;
  1572.     ImageWidth := FImage.FSize.X;
  1573.     ImageHeight := FImage.FSize.Y;
  1574.   end;
  1575.   Stream.Write(ImageDesc, SizeOf(TImageDescriptor));
  1576. end;
  1577.  
  1578. procedure TGIFFrame.WriteLocalColorMap(Stream: TStream);
  1579. begin
  1580.   if FLocalColors then
  1581.     with FImage.FColorMap do
  1582.       Stream.Write(Colors[0], Count * SizeOf(TGIFColorItem));
  1583. end;
  1584.  
  1585. procedure TGIFFrame.WriteRasterData(Stream: TStream);
  1586. begin
  1587.   Stream.WriteBuffer(FImage.FImageData.Memory^, FImage.FImageData.Size);
  1588. end;
  1589.  
  1590. procedure TGIFFrame.SaveToBitmapStream(Stream: TMemoryStream);
  1591.  
  1592.   function ConvertBitsPerPixel: TPixelFormat;
  1593.   begin
  1594.     Result := pfDevice;
  1595.     case FImage.FBitsPerPixel of
  1596.       1: Result := pf1bit;
  1597.       2..4: Result := pf4bit;
  1598.       5..8: Result := pf8bit;
  1599.       else GifError(LoadStr(SWrongGIFColors));
  1600.     end;
  1601.   end;
  1602.  
  1603. var
  1604.   HeaderSize: Longword;
  1605.   Length: Longword;
  1606.   BI: TBitmapInfoHeader;
  1607.   BitFile: TBitmapFileHeader;
  1608.   Colors: TRGBPalette;
  1609.   Bits: Pointer;
  1610.   Corrupt: Boolean;
  1611. begin
  1612.   with BI do begin
  1613.     biSize := Sizeof(TBitmapInfoHeader);
  1614.     biWidth := FImage.FSize.X;
  1615.     biHeight := FImage.FSize.Y;
  1616.     biPlanes := 1;
  1617.     biBitCount := 0;
  1618.     case ConvertBitsPerPixel of
  1619.       pf1bit: biBitCount := 1;
  1620.       pf4bit: biBitCount := 4;
  1621.       pf8bit: biBitCount := 8;
  1622.     end;
  1623.     biCompression := BI_RGB;
  1624.     biSizeImage := (((biWidth * biBitCount + 31) div 32) * 4) * biHeight;
  1625.     biXPelsPerMeter := 0;
  1626.     biYPelsPerMeter := 0;
  1627.     biClrUsed := 0;
  1628.     biClrImportant := 0;
  1629.   end;
  1630.   HeaderSize := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) +
  1631.     SizeOf(TRGBQuad) * (1 shl BI.biBitCount);
  1632.   Length := HeaderSize + BI.biSizeImage;
  1633.   Stream.SetSize(0);
  1634.   Stream.Position := 0;
  1635.   with BitFile do begin
  1636.     bfType := $4D42; { BM }
  1637.     bfSize := Length;
  1638.     bfOffBits := HeaderSize;
  1639.   end;
  1640.   Stream.Write(BitFile, SizeOf(TBitmapFileHeader));
  1641.   Stream.Write(BI, SizeOf(TBitmapInfoHeader));
  1642.   FillRGBPalette(FImage.FColorMap, Colors);
  1643.   Stream.Write(Colors, SizeOf(TRGBQuad) * (1 shl BI.biBitCount));
  1644.   Bits := AllocMemo(BI.biSizeImage);
  1645.   try
  1646.     ZeroMemory(Bits, BI.biSizeImage);
  1647.     FImage.FImageData.Position := 0;
  1648.     ReadGIFData(FImage.FImageData, BI, FInterlaced, GIFLoadCorrupted,
  1649.       FImage.FBitsPerPixel, Bits, Corrupt, FOwner.DoProgress);
  1650.     FCorrupted := FCorrupted or Corrupt;
  1651.     Stream.WriteBuffer(Bits^, BI.biSizeImage);
  1652.   finally
  1653.     FreeMemo(Bits);
  1654.   end;
  1655.   Stream.Position := 0;
  1656. end;
  1657.  
  1658. procedure TGIFFrame.LoadFromStream(Stream: TStream);
  1659. var
  1660.   ImageDesc: TImageDescriptor;
  1661.   I, TransIndex: Integer;
  1662. begin
  1663.   FImage.FImageData := TMemoryStream.Create;
  1664.   try
  1665.     ReadImageStream(Stream, FImage.FImageData, ImageDesc, FInterlaced,
  1666.       FLocalColors, FCorrupted, FImage.FBitsPerPixel, FImage.FColorMap);
  1667.     if FCorrupted and not GIFLoadCorrupted then GifError(ResStr(SReadError));
  1668.     FImage.FImageData.Position := 0;
  1669.     with ImageDesc do begin
  1670.       if ImageHeight = 0 then ImageHeight := FOwner.FScreenHeight;
  1671.       if ImageWidth = 0 then ImageWidth := FOwner.FScreenWidth;
  1672.       FTopLeft := Point(ImageLeftPos, ImageTopPos);
  1673.       FImage.FSize := Point(ImageWidth, ImageHeight);
  1674.       FImage.FPackedFields := PackedFields;
  1675.     end;
  1676.     if not FLocalColors then FImage.FColorMap := FOwner.FImage.FColorMap;
  1677.     FAnimateInterval := 0;
  1678.     if FExtensions <> nil then begin
  1679.       for I := 0 to FExtensions.Count - 1 do
  1680.         with TExtension(FExtensions[I]) do
  1681.           if FExtType = etGraphic then begin
  1682.             if (FExtRec.GCE.PackedFields and GCE_TRANSPARENT) <> 0 then
  1683.             begin
  1684.               TransIndex := FExtRec.GCE.TransparentColorIndex;
  1685.               if FImage.FColorMap.Count > TransIndex then
  1686.                 FTransparentColor := ItemToRGB(FImage.FColorMap.Colors[TransIndex]);
  1687.             end
  1688.             else FTransparentColor := clNone;
  1689.             FAnimateInterval := Max(FExtRec.GCE.DelayTime * 10,
  1690.               FAnimateInterval);
  1691.             FDisposal := TDisposalMethod((FExtRec.GCE.PackedFields and
  1692.               GCE_DISPOSAL_METHOD) shr 2);
  1693.           end;
  1694.     end;
  1695.   except
  1696.     FImage.FImageData.Free;
  1697.     FImage.FImageData := nil;
  1698.     raise;
  1699.   end;
  1700. end;
  1701.  
  1702. procedure TGIFFrame.Draw(ACanvas: TCanvas; const ARect: TRect;
  1703.   Transparent: Boolean);
  1704. begin
  1705.   if (FTransparentColor <> clNone) and Transparent then begin
  1706.     with ARect do
  1707.       StretchBitmapRectTransparent(ACanvas, Left, Top, Right - Left,
  1708.         Bottom - Top, Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap,
  1709.         FTransparentColor);
  1710.   end
  1711.   else ACanvas.StretchDraw(ARect, Bitmap);
  1712. end;
  1713.  
  1714. { TGIFImage }
  1715.  
  1716. constructor TGIFImage.Create;
  1717. begin
  1718.   inherited Create;
  1719.   NewImage;
  1720. {$IFDEF RX_D3}
  1721.   inherited SetTransparent(True);
  1722. {$ENDIF}
  1723. end;
  1724.  
  1725. destructor TGIFImage.Destroy;
  1726. begin
  1727.   OnChange := nil;
  1728.   FImage.Release;
  1729.   ClearItems;
  1730.   FItems.Free;
  1731.   inherited Destroy;
  1732. end;
  1733.  
  1734. procedure TGIFImage.Clear;
  1735. begin
  1736.   Assign(nil);
  1737. end;
  1738.  
  1739. procedure TGIFImage.ClearItems;
  1740. begin
  1741.   if FItems <> nil then
  1742.     while FItems.Count > 0 do begin
  1743.       TObject(FItems[0]).Free;
  1744.       FItems.Delete(0);
  1745.     end;
  1746. end;
  1747.  
  1748. procedure TGIFImage.Assign(Source: TPersistent);
  1749. var
  1750.   I: Integer;
  1751.   AFrame: TGIFFrame;
  1752. begin
  1753.   if (Source = nil) then begin
  1754.     NewImage;
  1755.     Changed(Self);
  1756.   end
  1757.   else if (Source is TGIFImage) and (Source <> Self) then begin
  1758.     FImage.Release;
  1759.     FImage := TGIFImage(Source).FImage;
  1760.     FImage.Reference;
  1761.     FVersion := TGIFImage(Source).FVersion;
  1762.     FBackgroundColor := TGIFImage(Source).FBackgroundColor;
  1763.     FRepeatCount := TGIFImage(Source).FRepeatCount;
  1764.     FLooping := TGIFImage(Source).FLooping;
  1765.     FCorrupted := TGIFImage(Source).FCorrupted;
  1766.     if FItems = nil then FItems := TList.Create
  1767.     else ClearItems;
  1768.     with TGIFImage(Source) do begin
  1769.       for I := 0 to FItems.Count - 1 do begin
  1770.         AFrame := TGIFFrame.Create(Self);
  1771.         try
  1772.           AFrame.FImage.FBitsPerPixel :=
  1773.             TGIFFrame(FItems[I]).FImage.FBitsPerPixel;
  1774.           AFrame.Assign(TGIFFrame(FItems[I]));
  1775.           AFrame.FLocalColors := TGIFFrame(FItems[I]).FLocalColors;
  1776.           Self.FItems.Add(AFrame);
  1777.         except
  1778.           AFrame.Free;
  1779.           raise;
  1780.         end;
  1781.       end;
  1782.       Self.FScreenWidth := FScreenWidth;
  1783.       Self.FScreenHeight := FScreenHeight;
  1784.     end;
  1785.     FFrameIndex := TGIFImage(Source).FFrameIndex;
  1786.     Changed(Self);
  1787.   end
  1788.   else if Source is TGIFFrame then begin
  1789.     NewImage;
  1790.     with TGIFFrame(Source).FOwner.FImage do begin
  1791.       FImage.FAspectRatio := FAspectRatio;
  1792.       FImage.FBitsPerPixel := FBitsPerPixel;
  1793.       FImage.FColorResBits := FColorResBits;
  1794.       Move(FColorMap, FImage.FColorMap, SizeOf(FColorMap));
  1795.     end;
  1796.     FFrameIndex := FItems.Add(TGIFFrame.Create(Self));
  1797.     TGIFFrame(FItems[FFrameIndex]).Assign(Source);
  1798.     if FVersion = gvUnknown then FVersion := gv87a;
  1799.     Changed(Self);
  1800.   end
  1801.   else if Source is TBitmap then begin
  1802.     NewImage;
  1803.     AddFrame(TBitmap(Source));
  1804.     Changed(Self);
  1805.   end
  1806.   else if Source is TAnimatedCursorImage then begin
  1807.     NewImage;
  1808.     FBackgroundColor := clWindow;
  1809.     with TAnimatedCursorImage(Source) do begin
  1810.       for I := 0 to IconCount - 1 do begin
  1811.         AddFrame(TIcon(Icons[I]));
  1812.         Self.Frames[FrameIndex].FAnimateInterval :=
  1813.           Longint(Frames[I].JiffRate * 100) div 6;
  1814.       end;
  1815.     end;
  1816.     Changed(Self);
  1817.   end
  1818.   else inherited Assign(Source);
  1819. end;
  1820.  
  1821. procedure TGIFImage.AssignTo(Dest: TPersistent);
  1822. begin
  1823.   if Dest is TGIFImage then Dest.Assign(Self)
  1824.   else if Dest is TGraphic then begin
  1825.     if Empty then
  1826.       Dest.Assign(nil)
  1827.     else if FFrameIndex >= 0 then
  1828.       TGIFFrame(FItems[FFrameIndex]).AssignTo(Dest)
  1829.     else Dest.Assign(Bitmap);
  1830.   end
  1831.   else inherited AssignTo(Dest);
  1832. end;
  1833.  
  1834. procedure TGIFImage.Draw(ACanvas: TCanvas; const ARect: TRect);
  1835. begin
  1836.   if FFrameIndex >= 0 then
  1837.     TGIFFrame(FItems[FFrameIndex]).Draw(ACanvas, ARect, Self.Transparent);
  1838. end;
  1839.  
  1840. function TGIFImage.GetBackgroundColor: TColor;
  1841. begin
  1842.   Result := FBackgroundColor;
  1843. end;
  1844.  
  1845. procedure TGIFImage.SetBackgroundColor(Value: TColor);
  1846. begin
  1847.   if Value <> FBackgroundColor then begin
  1848.     FBackgroundColor := Value;
  1849.     Changed(Self);
  1850.   end;
  1851. end;
  1852.  
  1853. procedure TGIFImage.SetLooping(Value: Boolean);
  1854. begin
  1855.   if Value <> FLooping then begin
  1856.     FLooping := Value;
  1857.     Changed(Self);
  1858.   end;
  1859. end;
  1860.  
  1861. procedure TGIFImage.SetRepeatCount(Value: Word);
  1862. begin
  1863.   if Min(Value, MAX_LOOP_COUNT) <> FRepeatCount then begin
  1864.     FRepeatCount := Min(Value, MAX_LOOP_COUNT);
  1865.     Changed(Self);
  1866.   end;
  1867. end;
  1868.  
  1869. function TGIFImage.GetPixelFormat: TPixelFormat;
  1870. var
  1871.   I: Integer;
  1872. begin
  1873.   Result := pfDevice;
  1874.   if not Empty then begin
  1875.     Result := ColorsToPixelFormat(FImage.FColorMap.Count);
  1876.     for I := 0 to FItems.Count - 1 do begin
  1877.       if (Frames[I].FImage.FImageData = nil) or
  1878.         (Frames[I].FImage.FImageData.Size = 0) then
  1879.       begin
  1880.         if Assigned(Frames[I].FBitmap) then
  1881.           Result := TPixelFormat(Max(Ord(Result),
  1882.             Ord(GetBitmapPixelFormat(Frames[I].FBitmap))))
  1883.         else Result := TPixelFormat(Max(Ord(Result), Ord(pfDevice)));
  1884.       end
  1885.       else if Frames[I].FLocalColors then
  1886.         Result := TPixelFormat(Max(Ord(Result),
  1887.           Ord(ColorsToPixelFormat(Frames[I].FImage.FColorMap.Count))));
  1888.     end;
  1889.   end;
  1890. end;
  1891.  
  1892. function TGIFImage.GetCorrupted: Boolean;
  1893. var
  1894.   I: Integer;
  1895. begin
  1896.   Result := FCorrupted;
  1897.   if not Result then
  1898.     for I := 0 to FItems.Count - 1 do
  1899.       if Frames[I].Corrupted then begin
  1900.         Result := True;
  1901.         Exit;
  1902.       end;
  1903. end;
  1904.  
  1905. function TGIFImage.GetTransparentColor: TColor;
  1906. begin
  1907.   if (FItems.Count > 0) and (FFrameIndex >= 0) then
  1908.     Result := TGIFFrame(FItems[FFrameIndex]).FTransparentColor
  1909.   else Result := clNone;
  1910. end;
  1911.  
  1912. function TGIFImage.GetCount: Integer;
  1913. begin
  1914.   Result := FItems.Count;
  1915. end;
  1916.  
  1917. function TGIFImage.GetFrame(Index: Integer): TGIFFrame;
  1918. begin
  1919.   Result := TGIFFrame(FItems[Index]);
  1920. end;
  1921.  
  1922. procedure TGIFImage.SetFrameIndex(Value: Integer);
  1923. begin
  1924.   Value := Min(FItems.Count - 1, Max(-1, Value));
  1925.   if FFrameIndex <> Value then begin
  1926.     FFrameIndex := Value;
  1927. {$IFDEF RX_D3}
  1928.     PaletteModified := True;
  1929. {$ENDIF}
  1930.     Changed(Self);
  1931.   end;
  1932. end;
  1933.  
  1934. {$IFDEF WIN32}
  1935. function TGIFImage.Equals(Graphic: TGraphic): Boolean;
  1936. begin
  1937.   Result := (Graphic is TGIFImage) and
  1938.     (FImage = TGIFImage(Graphic).FImage);
  1939. end;
  1940. {$ENDIF}
  1941.  
  1942. function TGIFImage.GetBitmap: TBitmap;
  1943. var
  1944.   Bmp: TBitmap;
  1945. begin
  1946.   if (FItems.Count > 0) then begin
  1947.     if (FFrameIndex >= 0) and (FFrameIndex < FItems.Count) then
  1948.       Result := TGIFFrame(FItems[FFrameIndex]).Bitmap
  1949.     else Result := TGIFFrame(FItems[0]).Bitmap
  1950.   end
  1951.   else begin
  1952.     FFrameIndex := 0;
  1953.     Bmp := TBitmap.Create;
  1954.     try
  1955.       Bmp.Handle := 0;
  1956.       Assign(Bmp);
  1957.       Result := TGIFFrame(FItems[FFrameIndex]).Bitmap;
  1958.     finally
  1959.       Bmp.Free;
  1960.     end;
  1961.   end;
  1962. end;
  1963.  
  1964. function TGIFImage.GetGlobalColorCount: Integer;
  1965. begin
  1966.   Result := FImage.FColormap.Count;
  1967. end;
  1968.  
  1969. function TGIFImage.GetEmpty: Boolean;
  1970. var
  1971.   I: Integer;
  1972. begin
  1973.   I := Max(FFrameIndex, 0);
  1974.   Result := (FItems.Count = 0) or
  1975.     ((TGIFFrame(FItems[I]).FBitmap = nil) and
  1976.     ((TGIFFrame(FItems[I]).FImage.FImageData = nil) or
  1977.     (TGIFFrame(FItems[I]).FImage.FImageData.Size = 0)));
  1978. end;
  1979.  
  1980. function TGIFImage.GetPalette: HPalette;
  1981. begin
  1982.   if FItems.Count > 0 then Result := Bitmap.Palette
  1983.   else Result := 0;
  1984. end;
  1985.  
  1986. function TGIFImage.GetTransparent: Boolean;
  1987. var
  1988.   I: Integer;
  1989. begin
  1990. {$IFDEF RX_D3}
  1991.   if inherited GetTransparent then
  1992. {$ENDIF}
  1993.     for I := 0 to FItems.Count - 1 do
  1994.       if Frames[I].TransparentColor <> clNone then begin
  1995.         Result := True;
  1996.         Exit;
  1997.       end;
  1998.   Result := False;
  1999. end;
  2000.  
  2001. function TGIFImage.GetHeight: Integer;
  2002. begin
  2003.   if not Empty and (FFrameIndex >= 0) and (FFrameIndex < Count) then
  2004.     Result := TGIFFrame(FItems[FFrameIndex]).Bitmap.Height
  2005.   else Result := 0;
  2006. end;
  2007.  
  2008. function TGIFImage.GetWidth: Integer;
  2009. begin
  2010.   if not Empty and (FFrameIndex >= 0) and (FFrameIndex < Count) then
  2011.     Result := TGIFFrame(FItems[FFrameIndex]).Bitmap.Width
  2012.   else Result := 0;
  2013. end;
  2014.  
  2015. function TGIFImage.GetScreenWidth: Integer;
  2016. begin
  2017.   if Empty then Result := 0
  2018.   else Result := FScreenWidth;
  2019. end;
  2020.  
  2021. function TGIFImage.GetScreenHeight: Integer;
  2022. begin
  2023.   if Empty then Result := 0
  2024.   else Result := FScreenHeight;
  2025. end;
  2026.  
  2027. procedure TGIFImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  2028.   APalette: HPALETTE);
  2029. var
  2030.   Bmp: TBitmap;
  2031.   Stream: TMemoryStream;
  2032.   Size: Longint;
  2033.   Buffer: Pointer;
  2034.   Data: THandle;
  2035. begin
  2036.   { !! check for gif clipboard Data, mime type image/gif }
  2037.   Data := GetClipboardData(CF_GIF);
  2038.   if Data <> 0 then begin
  2039.     Buffer := GlobalLock(Data);
  2040.     try
  2041.       Stream := TMemoryStream.Create;
  2042.       try
  2043.         Stream.Write(Buffer^, GlobalSize(Data));
  2044.         Stream.Position := 0;
  2045.         Stream.Read(Size, SizeOf(Size));
  2046.         ReadStream(Size, Stream, False);
  2047.         if Count > 0 then begin
  2048.           FFrameIndex := 0;
  2049.           AData := GetClipboardData(CF_BITMAP);
  2050.           if AData <> 0 then begin
  2051.             Frames[0].NewBitmap;
  2052.             Frames[0].FBitmap.LoadFromClipboardFormat(CF_BITMAP,
  2053.               AData, APalette);
  2054.           end;
  2055.         end;
  2056.       finally
  2057.         Stream.Free;
  2058.       end;
  2059.     finally
  2060.       GlobalUnlock(Data);
  2061.     end;
  2062.   end
  2063.   else begin
  2064.     Bmp := TBitmap.Create;
  2065.     try
  2066.       Bmp.LoadFromClipboardFormat(AFormat, AData, APalette);
  2067.       Assign(Bmp);
  2068.     finally
  2069.       Bmp.Free;
  2070.     end;
  2071.   end;
  2072. end;
  2073.  
  2074. procedure TGIFImage.LoadFromStream(Stream: TStream);
  2075. begin
  2076.   ReadStream(Stream.Size - Stream.Position, Stream, True);
  2077. end;
  2078.  
  2079. procedure TGIFImage.LoadFromResourceName(Instance: THandle; const ResName: string;
  2080.   ResType: PChar);
  2081. var
  2082.   Stream: TStream;
  2083. begin
  2084.   Stream := TResourceStream.Create(Instance, ResName, ResType);
  2085.   try
  2086.     ReadStream(Stream.Size - Stream.Position, Stream, True);
  2087.   finally
  2088.     Stream.Free;
  2089.   end;
  2090. end;
  2091.  
  2092. procedure TGIFImage.LoadFromResourceID(Instance: THandle; ResID: Integer;
  2093.   ResType: PChar);
  2094. var
  2095.   Stream: TStream;
  2096. begin
  2097.   Stream := TResourceStream.CreateFromID(Instance, ResID, ResType);
  2098.   try
  2099.     ReadStream(Stream.Size - Stream.Position, Stream, True);
  2100.   finally
  2101.     Stream.Free;
  2102.   end;
  2103. end;
  2104.  
  2105. procedure TGIFImage.UpdateScreenSize;
  2106. var
  2107.   I: Integer;
  2108. begin
  2109.   FScreenWidth := 0;
  2110.   FScreenHeight := 0;
  2111.   for I := 0 to FItems.Count - 1 do
  2112.     if Frames[I] <> nil then begin
  2113.       FScreenWidth := Max(FScreenWidth, Frames[I].Width +
  2114.         Frames[I].FTopLeft.X);
  2115.       FScreenHeight := Max(FScreenHeight, Frames[I].Height +
  2116.         Frames[I].FTopLeft.Y);
  2117.     end;
  2118. end;
  2119.  
  2120. function TGIFImage.AddFrame(Value: TGraphic): Integer;
  2121. begin
  2122.   FFrameIndex := FItems.Add(TGIFFrame.Create(Self));
  2123.   TGIFFrame(FItems[FFrameIndex]).Assign(Value);
  2124.   if FVersion = gvUnknown then FVersion := gv87a;
  2125.   if FItems.Count > 1 then FVersion := gv89a;
  2126.   Result := FFrameIndex;
  2127. end;
  2128.  
  2129. procedure TGIFImage.DeleteFrame(Index: Integer);
  2130. begin
  2131.   Frames[Index].Free;
  2132.   FItems.Delete(Index);
  2133.   UpdateScreenSize;
  2134.   if FFrameIndex >= FItems.Count then Dec(FFrameIndex);
  2135.   Changed(Self);
  2136. end;
  2137.  
  2138. procedure TGIFImage.MoveFrame(CurIndex, NewIndex: Integer);
  2139. begin
  2140.   FItems.Move(CurIndex, NewIndex);
  2141.   FFrameIndex := NewIndex;
  2142.   Changed(Self);
  2143. end;
  2144.  
  2145. procedure TGIFImage.NewImage;
  2146. begin
  2147.   if FImage <> nil then FImage.Release;
  2148.   FImage := TGIFData.Create;
  2149.   FImage.Reference;
  2150.   if FItems = nil then FItems := TList.Create;
  2151.   ClearItems;
  2152.   FCorrupted := False;
  2153.   FFrameIndex := -1;
  2154.   FBackgroundColor := clNone;
  2155.   FRepeatCount := 1;
  2156.   FLooping := False;
  2157.   FVersion := gvUnknown;
  2158. end;
  2159.  
  2160. procedure TGIFImage.UniqueImage;
  2161. var
  2162.   Temp: TGIFData;
  2163. begin
  2164.   if FImage = nil then NewImage
  2165.   else if FImage.RefCount > 1 then begin
  2166.     Temp := TGIFData.Create;
  2167.     with Temp do
  2168.     try
  2169.       FComment.Assign(FImage.FComment);
  2170.       FAspectRatio := FImage.FAspectRatio;
  2171.       FBitsPerPixel := FImage.FBitsPerPixel;
  2172.       FColorResBits := FImage.FColorResBits;
  2173.       FColorMap := FImage.FColorMap;
  2174.     except
  2175.       Temp.Free;
  2176.       raise;
  2177.     end;
  2178.     FImage.Release;
  2179.     FImage := Temp;
  2180.     FImage.Reference;
  2181.   end;
  2182. end;
  2183.  
  2184. function TGIFImage.GetComment: TStrings;
  2185. begin
  2186.   Result := FImage.FComment;
  2187. end;
  2188.  
  2189. procedure TGIFImage.SetComment(Value: TStrings);
  2190. begin
  2191.   UniqueImage;
  2192.   FImage.FComment.Assign(Value);
  2193. end;
  2194.  
  2195. procedure TGIFImage.DecodeAllFrames;
  2196. var
  2197.   FrameNo, I: Integer;
  2198. begin
  2199.   for FrameNo := 0 to FItems.Count - 1 do
  2200.     try
  2201.       TGIFFrame(FItems[FrameNo]).GetBitmap;
  2202.     except
  2203.       on EAbort do begin { OnProgress can raise EAbort to cancel image load }
  2204.         for I := FItems.Count - 1 downto FrameNo do begin
  2205.           TObject(FItems[I]).Free;
  2206.           FItems.Delete(I);
  2207.         end;
  2208.         FCorrupted := True;
  2209.         Break;
  2210.       end;
  2211.       else raise;
  2212.     end;
  2213. end;
  2214.  
  2215. procedure TGIFImage.EncodeFrames(ReverseDecode: Boolean);
  2216. var
  2217.   FrameNo: Integer;
  2218. begin
  2219.   for FrameNo := 0 to FItems.Count - 1 do
  2220.     with TGIFFrame(FItems[FrameNo]) do begin
  2221.       if (FImage.FImageData = nil) or (FImage.FImageData.Size = 0) then
  2222.       begin
  2223.         FImage.FImageData.Free;
  2224.         FImage.FImageData := nil;
  2225.         EncodeRasterData;
  2226.         if ReverseDecode and (FBitmap.Palette = 0) then begin
  2227.           FBitmap.Free;
  2228.           FBitmap := nil;
  2229.           try
  2230.             GetBitmap;
  2231.           except
  2232.             on EAbort do; { OnProgress can raise EAbort to cancel encoding }
  2233.             else raise;
  2234.           end;
  2235.         end;
  2236.       end;
  2237.       UpdateExtensions;
  2238.     end;
  2239. end;
  2240.  
  2241. procedure TGIFImage.EncodeAllFrames;
  2242. begin
  2243.   EncodeFrames(True);
  2244. end;
  2245.  
  2246. procedure TGIFImage.ReadData(Stream: TStream);
  2247. var
  2248.   Size: Longint;
  2249. begin
  2250.   Stream.Read(Size, SizeOf(Size));
  2251.   ReadStream(Size, Stream, True);
  2252. end;
  2253.  
  2254. procedure TGIFImage.ReadSignature(Stream: TStream);
  2255. var
  2256.   I: TGIFVersion;
  2257.   S: string[3];
  2258. begin
  2259.   FVersion := gvUnknown;
  2260.   SetLength(S, 3);
  2261.   Stream.Read(S[1], 3);
  2262.   if CompareText(GIFSignature, S) <> 0 then GifError(LoadStr(SGIFVersion));
  2263.   SetLength(S, 3);
  2264.   Stream.Read(S[1], 3);
  2265.   for I := Low(TGIFVersion) to High(TGIFVersion) do
  2266.     if CompareText(S, StrPas(GIFVersionStr[I])) = 0 then begin
  2267.       FVersion := I;
  2268.       Break;
  2269.     end;
  2270.   if FVersion = gvUnknown then GifError(LoadStr(SGIFVersion));
  2271. end;
  2272.  
  2273. procedure TGIFImage.ReadStream(Size: Longint; Stream: TStream;
  2274.   ForceDecode: Boolean);
  2275. var
  2276.   SeparatorChar: Char;
  2277.   NewItem: TGIFFrame;
  2278.   Extensions: TList;
  2279.   ScreenDesc: TScreenDescriptor;
  2280.   Data: TMemoryStream;
  2281.  
  2282.   procedure ReadScreenDescriptor(Stream: TStream);
  2283.   begin
  2284.     Stream.Read(ScreenDesc, SizeOf(ScreenDesc));
  2285.     FScreenWidth := ScreenDesc.ScreenWidth;
  2286.     FScreenHeight := ScreenDesc.ScreenHeight;
  2287.     with FImage do begin
  2288.       FAspectRatio := ScreenDesc.AspectRatio;
  2289.       FBitsPerPixel := 1 + (ScreenDesc.PackedFields and
  2290.         LSD_COLOR_TABLE_SIZE);
  2291.       FColorResBits := 1 + (ScreenDesc.PackedFields and
  2292.         LSD_COLOR_RESOLUTION) shr 4;
  2293.     end;
  2294.   end;
  2295.  
  2296.   procedure ReadGlobalColorMap(Stream: TStream);
  2297.   begin
  2298.     if (ScreenDesc.PackedFields and LSD_GLOBAL_COLOR_TABLE) <> 0 then
  2299.       with FImage.FColorMap do begin
  2300.         Count := 1 shl FImage.FBitsPerPixel;
  2301.         Stream.Read(Colors[0], Count * SizeOf(TGIFColorItem));
  2302.         if Count > ScreenDesc.BackgroundColorIndex then
  2303.           FBackgroundColor := ItemToRGB(Colors[ScreenDesc.BackgroundColorIndex]);
  2304.       end;
  2305.   end;
  2306.  
  2307.   function ReadDataBlock(Stream: TStream): TStrings;
  2308.   var
  2309.     BlockSize: Byte;
  2310.     S: string;
  2311.   begin
  2312.     Result := TStringlist.Create;
  2313.     try
  2314.       repeat
  2315.         Stream.Read(BlockSize, SizeOf(Byte));
  2316.         if BlockSize <> 0 then begin
  2317.           SetLength(S, BlockSize);
  2318.           Stream.Read(S[1], BlockSize);
  2319.           Result.Add(S);
  2320.         end;
  2321.       until (BlockSize = 0) or (Stream.Position >= Stream.Size);
  2322.     except
  2323.       Result.Free;
  2324.       raise;
  2325.     end;
  2326.   end;
  2327.  
  2328.   function ReadExtension(Stream: TStream): TExtension;
  2329.   var
  2330.     ExtensionLabel: Byte;
  2331.   begin
  2332.     Result := TExtension.Create;
  2333.     try
  2334.       Stream.Read(ExtensionLabel, SizeOf(Byte));
  2335.       with Result do
  2336.         if ExtensionLabel = ExtLabels[etGraphic] then begin
  2337.           { graphic control extension }
  2338.           FExtType := etGraphic;
  2339.           Stream.Read(FExtRec.GCE, SizeOf(TGraphicControlExtension));
  2340.         end
  2341.         else if ExtensionLabel = ExtLabels[etComment] then begin
  2342.           { comment extension }
  2343.           FExtType := etComment;
  2344.           FData := ReadDataBlock(Stream);
  2345.         end
  2346.         else if ExtensionLabel = ExtLabels[etPlainText] then begin
  2347.           { plain text extension }
  2348.           FExtType := etPlainText;
  2349.           Stream.Read(FExtRec.PTE, SizeOf(TPlainTextExtension));
  2350.           FData := ReadDataBlock(Stream);
  2351.         end
  2352.         else if ExtensionLabel = ExtLabels[etApplication] then begin
  2353.           { application extension }
  2354.           FExtType := etApplication;
  2355.           Stream.Read(FExtRec.APPE, SizeOf(TAppExtension));
  2356.           FData := ReadDataBlock(Stream);
  2357.         end
  2358.         else GifError(Format(LoadStr(SUnrecognizedGIFExt), [ExtensionLabel]));
  2359.     except
  2360.       Result.Free;
  2361.       raise;
  2362.     end;
  2363.   end;
  2364.  
  2365.   function ReadSeparator(Stream: TStream): Char;
  2366.   begin
  2367.     Result := #0;
  2368.     while (Stream.Size > Stream.Position) and (Result = #0) do
  2369.       Stream.Read(Result, SizeOf(Byte));
  2370.   end;
  2371.  
  2372.   function ReadExtensionBlock(Stream: TStream; var SeparatorChar: Char): TList;
  2373.   var
  2374.     NewExt: TExtension;
  2375.   begin
  2376.     Result := nil;
  2377.     try
  2378.       while SeparatorChar = CHR_EXT_INTRODUCER do begin
  2379.         NewExt := ReadExtension(Stream);
  2380.         if (NewExt.FExtType = etPlainText) then begin
  2381.           { plain text data blocks are not supported,
  2382.             clear all previous readed extensions }
  2383.           FreeExtensions(Result);
  2384.           Result := nil;
  2385.         end;
  2386.         if (NewExt.FExtType in [etPlainText, etApplication]) then begin
  2387.           { check for loop extension }
  2388.           if NewExt.IsLoopExtension then begin
  2389.             FLooping := True;
  2390.             FRepeatCount := Min(MakeWord(Byte(NewExt.FData[0][2]),
  2391.               Byte(NewExt.FData[0][3])), MAX_LOOP_COUNT);
  2392.           end;
  2393.           { not supported yet, must be ignored }
  2394.           NewExt.Free;
  2395.         end
  2396.         else begin
  2397.           if Result = nil then Result := TList.Create;
  2398.           Result.Add(NewExt);
  2399.         end;
  2400.         if Stream.Size > Stream.Position then
  2401.           SeparatorChar := ReadSeparator(Stream)
  2402.         else SeparatorChar := CHR_TRAILER;
  2403.       end;
  2404.       if (Result <> nil) and (Result.Count = 0) then begin
  2405.         Result.Free;
  2406.         Result := nil;
  2407.       end;
  2408.     except
  2409.       if Result <> nil then Result.Free;
  2410.       raise;
  2411.     end;
  2412.   end;
  2413.  
  2414. var
  2415.   I: Integer;
  2416.   Ext: TExtension;
  2417. begin
  2418.   NewImage;
  2419.   with FImage do begin
  2420.     Data := TMemoryStream.Create;
  2421.     try
  2422.       TMemoryStream(Data).SetSize(Size);
  2423.       Stream.ReadBuffer(Data.Memory^, Size);
  2424.       if Size > 0 then begin
  2425.         Data.Position := 0;
  2426.         ReadSignature(Data);
  2427.         ReadScreenDescriptor(Data);
  2428.         ReadGlobalColorMap(Data);
  2429.         SeparatorChar := ReadSeparator(Data);
  2430.         while not (SeparatorChar in [CHR_TRAILER, #0]) and not
  2431.           (Data.Position >= Data.Size) do
  2432.         begin
  2433.           Extensions := ReadExtensionBlock(Data, SeparatorChar);
  2434.           if SeparatorChar = CHR_IMAGE_SEPARATOR then
  2435.             try
  2436.               NewItem := TGIFFrame.Create(Self);
  2437.               try
  2438.                 if FImage.FColorMap.Count > 0 then
  2439.                   NewItem.FImage.FBitsPerPixel :=
  2440.                     ColorsToBits(FImage.FColorMap.Count);
  2441.                 NewItem.FExtensions := Extensions;
  2442.                 Extensions := nil;
  2443.                 NewItem.LoadFromStream(Data);
  2444.                 FItems.Add(NewItem);
  2445.               except
  2446.                 NewItem.Free;
  2447.                 raise;
  2448.               end;
  2449.               if not (Data.Position >= Data.Size) then begin
  2450.                 SeparatorChar := ReadSeparator(Data);
  2451.               end
  2452.               else SeparatorChar := CHR_TRAILER;
  2453.               if not (SeparatorChar in [CHR_EXT_INTRODUCER,
  2454.                 CHR_IMAGE_SEPARATOR, CHR_TRAILER]) then
  2455.               begin
  2456.                 SeparatorChar := #0;
  2457.                 {GifError(LoadStr(SGIFDecodeError));}
  2458.               end;
  2459.             except
  2460.               FreeExtensions(Extensions);
  2461.               raise;
  2462.             end
  2463.           else if (FComment.Count = 0) and (Extensions <> nil) then begin
  2464.             try
  2465.               { trailig extensions }
  2466.               for I := 0 to Extensions.Count - 1 do begin
  2467.                 Ext := TExtension(Extensions[I]);
  2468.                 if (Ext <> nil) and (Ext.FExtType = etComment) then begin
  2469.                   if FComment.Count > 0 then
  2470.                     FComment.Add(#13#10#13#10);
  2471.                   FComment.AddStrings(Ext.FData);
  2472.                 end;
  2473.               end;
  2474.             finally
  2475.               FreeExtensions(Extensions);
  2476.             end;
  2477.           end
  2478.           else if not (SeparatorChar in [CHR_TRAILER, #0]) then
  2479.             GifError(ResStr(SReadError));
  2480.         end;
  2481.       end;
  2482.     finally
  2483.       Data.Free;
  2484.     end;
  2485.   end;
  2486.   if Count > 0 then begin
  2487.     FFrameIndex := 0;
  2488.     if ForceDecode then
  2489.     try
  2490.       GetBitmap; { force bitmap creation }
  2491.     except
  2492.       Frames[0].Free;
  2493.       FItems.Delete(0);
  2494.       raise;
  2495.     end;
  2496.   end;
  2497. {$IFDEF RX_D3}
  2498.   PaletteModified := True;
  2499. {$ENDIF}
  2500.   Changed(Self);
  2501. end;
  2502.  
  2503. procedure TGIFImage.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  2504.   var APalette: HPALETTE);
  2505. var
  2506.   Stream: TMemoryStream;
  2507.   Data: THandle;
  2508.   Buffer: Pointer;
  2509.   I: Integer;
  2510. begin
  2511.   { !! check for gif clipboard format, mime type image/gif }
  2512.   if FItems.Count = 0 then Exit;
  2513.   Frames[0].Bitmap.SaveToClipboardFormat(AFormat, AData, APalette);
  2514.   for I := 0 to FItems.Count - 1 do
  2515.     with Frames[I] do begin
  2516.       if (FImage.FImageData = nil) or (FImage.FImageData.Size = 0) then
  2517.         Exit;
  2518.     end;
  2519.   Stream := TMemoryStream.Create;
  2520.   try
  2521.     WriteStream(Stream, True);
  2522.     Stream.Position := 0;
  2523.     Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
  2524.     try
  2525.       if Data <> 0 then begin
  2526.         Buffer := GlobalLock(Data);
  2527.         try
  2528.           Stream.Read(Buffer^, Stream.Size);
  2529.           SetClipboardData(CF_GIF, Data);
  2530.         finally
  2531.           GlobalUnlock(Data);
  2532.         end;
  2533.       end;
  2534.     except
  2535.       GlobalFree(Data);
  2536.       raise;
  2537.     end;
  2538.   finally
  2539.     Stream.Free;
  2540.   end;
  2541. end;
  2542.  
  2543. procedure TGIFImage.WriteData(Stream: TStream);
  2544. begin
  2545.   WriteStream(Stream, True);
  2546. end;
  2547.  
  2548. procedure TGIFImage.SetHeight(Value: Integer);
  2549. begin
  2550.   GifError(LoadStr(SChangeGIFSize));
  2551. end;
  2552.  
  2553. procedure TGIFImage.SetWidth(Value: Integer);
  2554. begin
  2555.   GifError(LoadStr(SChangeGIFSize));
  2556. end;
  2557.  
  2558. procedure TGIFImage.WriteStream(Stream: TStream; WriteSize: Boolean);
  2559. var
  2560.   Separator: Char;
  2561.   Temp: Byte;
  2562.   FrameNo: Integer;
  2563.   Frame: TGIFFrame;
  2564.   Mem: TMemoryStream;
  2565.   Size: Longint;
  2566.   StrList: TStringList;
  2567.  
  2568.   procedure WriteSignature(Stream: TStream);
  2569.   var
  2570.     Header: TGIFHeader;
  2571.   begin
  2572.     Header.Signature := GIFSignature;
  2573.     Move(GIFVersionStr[FVersion][0], Header.Version[0], 3);
  2574.     Stream.Write(Header, SizeOf(TGIFHeader));
  2575.   end;
  2576.  
  2577.   procedure WriteScreenDescriptor(Stream: TStream);
  2578.   var
  2579.     ColorResBits: Byte;
  2580.     ScreenDesc: TScreenDescriptor;
  2581.     I: Integer;
  2582.   begin
  2583.     UpdateScreenSize;
  2584.     with ScreenDesc do begin
  2585.       ScreenWidth := Self.FScreenWidth;
  2586.       ScreenHeight := Self.FScreenHeight;
  2587.       AspectRatio := FImage.FAspectRatio;
  2588.       PackedFields := 0;
  2589.       BackgroundColorIndex := 0;
  2590.       if FImage.FColorMap.Count > 0 then begin
  2591.         PackedFields := PackedFields or LSD_GLOBAL_COLOR_TABLE;
  2592.         ColorResBits := ColorsToBits(FImage.FColorMap.Count);
  2593.         if FBackgroundColor <> clNone then
  2594.           for I := 0 to FImage.FColorMap.Count - 1 do
  2595.             if ColorToRGB(FBackgroundColor) =
  2596.               ItemToRGB(FImage.FColorMap.Colors[I]) then
  2597.             begin
  2598.               BackgroundColorIndex := I;
  2599.               Break;
  2600.             end;
  2601.         PackedFields := PackedFields + ((ColorResBits - 1) shl 4) +
  2602.           (FImage.FBitsPerPixel - 1);
  2603.       end;
  2604.     end;
  2605.     Stream.Write(ScreenDesc, SizeOf(ScreenDesc));
  2606.   end;
  2607.  
  2608.   procedure WriteDataBlock(Stream: TStream; Data: TStrings);
  2609.   var
  2610.     I: Integer;
  2611.     S: string;
  2612.     BlockSize: Byte;
  2613.   begin
  2614.     for I := 0 to Data.Count - 1 do begin
  2615.       S := Data[I];
  2616.       BlockSize := Min(Length(S), 255);
  2617.       if BlockSize > 0 then begin
  2618.         Stream.Write(BlockSize, SizeOf(Byte));
  2619.         Stream.Write(S[1], BlockSize);
  2620.       end;
  2621.     end;
  2622.     BlockSize := 0;
  2623.     Stream.Write(BlockSize, SizeOf(Byte));
  2624.   end;
  2625.  
  2626.   procedure WriteExtensionBlock(Stream: TStream; Extensions: TList);
  2627.   var
  2628.     I: Integer;
  2629.     Ext: TExtension;
  2630.     ExtensionLabel: Byte;
  2631.     SeparateChar: Char;
  2632.   begin
  2633.     SeparateChar := CHR_EXT_INTRODUCER;
  2634.     for I := 0 to Extensions.Count - 1 do begin
  2635.       Ext := TExtension(Extensions[I]);
  2636.       if Ext <> nil then begin
  2637.         Stream.Write(SeparateChar, SizeOf(Byte));
  2638.         ExtensionLabel := ExtLabels[Ext.FExtType];
  2639.         Stream.Write(ExtensionLabel, SizeOf(Byte));
  2640.         case Ext.FExtType of
  2641.           etGraphic:
  2642.             begin
  2643.               Stream.Write(Ext.FExtRec.GCE, SizeOf(TGraphicControlExtension));
  2644.             end;
  2645.           etComment: WriteDataBlock(Stream, Ext.FData);
  2646.           etPlainText:
  2647.             begin
  2648.               Stream.Write(Ext.FExtRec.PTE, SizeOf(TPlainTextExtension));
  2649.               WriteDataBlock(Stream, Ext.FData);
  2650.             end;
  2651.           etApplication:
  2652.             begin
  2653.               Stream.Write(Ext.FExtRec.APPE, SizeOf(TAppExtension));
  2654.               WriteDataBlock(Stream, Ext.FData);
  2655.             end;
  2656.         end;
  2657.       end;
  2658.     end;
  2659.   end;
  2660.  
  2661. begin
  2662.   if FItems.Count = 0 then GifError(LoadStr(SNoGIFData));
  2663.   EncodeFrames(False);
  2664.   Mem := TMemoryStream.Create;
  2665.   try
  2666.     if FImage.FComment.Count > 0 then FVersion := gv89a;
  2667.     WriteSignature(Mem);
  2668.     WriteScreenDescriptor(Mem);
  2669.     if FImage.FColorMap.Count > 0 then begin
  2670.       with FImage.FColorMap do
  2671.         Mem.Write(Colors[0], Count * SizeOf(TGIFColorItem));
  2672.     end;
  2673.     if FLooping and (FItems.Count > 1) then begin
  2674.       { write looping extension }
  2675.       Separator := CHR_EXT_INTRODUCER;
  2676.       Mem.Write(Separator, SizeOf(Byte));
  2677.       Temp := ExtLabels[etApplication];
  2678.       Mem.Write(Temp, SizeOf(Byte));
  2679.       Temp := SizeOf(TAppExtension) - SizeOf(Byte);
  2680.       Mem.Write(Temp, SizeOf(Byte));
  2681.       Mem.Write(LoopExtNS[1], Temp);
  2682.       StrList := TStringList.Create;
  2683.       try
  2684.         StrList.Add(Char(AE_LOOPING) + Char(LoByte(FRepeatCount)) +
  2685.           Char(HiByte(FRepeatCount)));
  2686.         WriteDataBlock(Mem, StrList);
  2687.       finally
  2688.         StrList.Free;
  2689.       end;
  2690.     end;
  2691.     Separator := CHR_IMAGE_SEPARATOR;
  2692.     for FrameNo := 0 to FItems.Count - 1 do begin
  2693.       Frame := TGIFFrame(FItems[FrameNo]);
  2694.       if Frame.FExtensions <> nil then
  2695.         WriteExtensionBlock(Mem, Frame.FExtensions);
  2696.       Mem.Write(Separator, SizeOf(Byte));
  2697.       Frame.WriteImageDescriptor(Mem);
  2698.       Frame.WriteLocalColorMap(Mem);
  2699.       Frame.WriteRasterData(Mem);
  2700.     end;
  2701.     if FImage.FComment.Count > 0 then begin
  2702.       Separator := CHR_EXT_INTRODUCER;
  2703.       Mem.Write(Separator, SizeOf(Byte));
  2704.       Temp := ExtLabels[etComment];
  2705.       Mem.Write(Temp, SizeOf(Byte));
  2706.       WriteDataBlock(Mem, FImage.FComment);
  2707.     end;
  2708.     Separator := CHR_TRAILER;
  2709.     Mem.Write(Separator, SizeOf(Byte));
  2710.     Size := Mem.Size;
  2711.     if WriteSize then Stream.Write(Size, SizeOf(Size));
  2712.     Stream.Write(Mem.Memory^, Size);
  2713.   finally
  2714.     Mem.Free;
  2715.   end;
  2716. end;
  2717.  
  2718. procedure TGIFImage.Grayscale(ForceEncoding: Boolean);
  2719. var
  2720.   I: Integer;
  2721. begin
  2722.   if FItems.Count = 0 then GifError(LoadStr(SNoGIFData));
  2723.   for I := 0 to FItems.Count - 1 do
  2724.     Frames[I].GrayscaleImage(ForceEncoding);
  2725.   if FBackgroundColor <> clNone then begin
  2726.     if FImage.FColorMap.Count > 0 then begin
  2727.       I := FindColorIndex(FImage.FColorMap, FBackgroundColor);
  2728.       GrayColorTable(FImage.FColorMap);
  2729.       if I >= 0 then
  2730.         FBackgroundColor := ItemToRGB(FImage.FColorMap.Colors[I])
  2731.       else FBackgroundColor := GrayColor(FBackgroundColor);
  2732.     end
  2733.     else FBackgroundColor := GrayColor(FBackgroundColor);
  2734.   end;
  2735. {$IFDEF RX_D3}
  2736.   PaletteModified := True;
  2737. {$ENDIF}
  2738.   Changed(Self);
  2739. end;
  2740.  
  2741. procedure TGIFImage.SaveToStream(Stream: TStream);
  2742. begin
  2743.   WriteStream(Stream, False);
  2744. end;
  2745.  
  2746. procedure TGIFImage.DoProgress(Stage: TProgressStage; PercentDone: Byte;
  2747.   const Msg: string);
  2748. begin
  2749.   Progress(Self, Stage, PercentDone, False, Rect(0, 0, 0, 0), Msg);
  2750. end;
  2751.  
  2752. {$IFNDEF RX_D3}
  2753. procedure TGIFImage.Progress(Sender: TObject; Stage: TProgressStage;
  2754.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  2755. begin
  2756.   if Assigned(FOnProgress) then
  2757.     FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
  2758. end;
  2759. {$ENDIF}
  2760.  
  2761. initialization
  2762.   CF_GIF := RegisterClipboardFormat('GIF Image');
  2763.   RegisterClasses([TGIFFrame, TGIFImage]);
  2764. {$IFDEF USE_RX_GIF}
  2765.   TPicture.RegisterFileFormat('gif', LoadStr(SGIFImage), TGIFImage);
  2766.   TPicture.RegisterClipboardFormat(CF_GIF, TGIFImage);
  2767.  {$IFDEF RX_D3}
  2768. finalization
  2769.   TPicture.UnRegisterGraphicClass(TGIFImage);
  2770.  {$ENDIF}
  2771. {$ENDIF}
  2772. end.